From 92cca1c5bf9c7329af96e70b891b3e5ac273cc5f Mon Sep 17 00:00:00 2001 From: thchang Date: Sat, 12 Mar 2022 00:58:22 -0600 Subject: [PATCH 1/8] restructuring package for compatibility with package managers --- Makefile | 110 + README.md | 67 +- USAGE | 549 ++ {src => data/varsys}/sample_input2d.dat | 0 {src => data/varsys}/sample_input4d.dat | 0 {c_binding => extras/c_binding}/LICENSE | 0 {c_binding => extras/c_binding}/Makefile | 15 +- {c_binding => extras/c_binding}/README | 0 {c_binding => extras/c_binding}/delsparse.f90 | 0 extras/c_binding/delsparse.h | 59 + .../c_binding}/delsparse_bind_c.f90 | 0 .../c_binding/dependencies}/blas.f | 0 .../c_binding/dependencies}/lapack.f | 0 .../c_binding/dependencies}/slatec.f | 124 +- extras/c_binding/test_install | Bin 0 -> 276896 bytes .../c_binding}/test_install.c | 56 +- {python => extras/delsparsepy}/LICENSE | 0 {python => extras/delsparsepy}/README | 0 {python => extras/delsparsepy}/delsparse.py | 0 .../delsparsepy/delsparse_src}/blas.f | 0 .../delsparsepy/delsparse_src}/delsparse.f90 | 0 .../delsparse_src}/delsparse_bind_c.f90 | 0 .../delsparsepy/delsparse_src}/lapack.f | 0 .../delsparse_src}/real_precision.f90 | 0 .../delsparsepy/delsparse_src}/slatec.f | 124 +- {python => extras/delsparsepy}/example.py | 0 src/delsparsep | Bin 0 -> 231136 bytes src/delsparses | Bin 0 -> 231136 bytes src/{ => dependencies}/blas.f | 0 src/{ => dependencies}/lapack.f | 0 src/dependencies/slatec.f | 5023 +++++++++++++++++ test/test_bin.sh | 46 + test/test_c_install.c | 149 + {src => test}/test_install.f90 | 0 {src => toms1012}/LICENSE | 0 {src => toms1012}/Makefile | 0 {src => toms1012}/README | 0 toms1012/blas.f | 2206 ++++++++ toms1012/delsparse.f90 | 2778 +++++++++ toms1012/lapack.f | 4369 ++++++++++++++ toms1012/sample_input2d.dat | 188 + toms1012/sample_input4d.dat | 1297 +++++ toms1012/samplep.f90 | 155 + toms1012/samples.f90 | 155 + {c_binding => toms1012}/slatec.f | 0 toms1012/test_install.f90 | 153 + 46 files changed, 17403 insertions(+), 220 deletions(-) create mode 100644 Makefile create mode 100644 USAGE rename {src => data/varsys}/sample_input2d.dat (100%) rename {src => data/varsys}/sample_input4d.dat (100%) rename {c_binding => extras/c_binding}/LICENSE (100%) rename {c_binding => extras/c_binding}/Makefile (52%) rename {c_binding => extras/c_binding}/README (100%) rename {c_binding => extras/c_binding}/delsparse.f90 (100%) create mode 100644 extras/c_binding/delsparse.h rename {c_binding => extras/c_binding}/delsparse_bind_c.f90 (100%) rename {c_binding => extras/c_binding/dependencies}/blas.f (100%) rename {c_binding => extras/c_binding/dependencies}/lapack.f (100%) rename {python => extras/c_binding/dependencies}/slatec.f (98%) mode change 100755 => 100644 create mode 100755 extras/c_binding/test_install rename {c_binding => extras/c_binding}/test_install.c (60%) rename {python => extras/delsparsepy}/LICENSE (100%) rename {python => extras/delsparsepy}/README (100%) rename {python => extras/delsparsepy}/delsparse.py (100%) rename {python => extras/delsparsepy/delsparse_src}/blas.f (100%) rename {python => extras/delsparsepy/delsparse_src}/delsparse.f90 (100%) rename {python => extras/delsparsepy/delsparse_src}/delsparse_bind_c.f90 (100%) rename {python => extras/delsparsepy/delsparse_src}/lapack.f (100%) rename {python => extras/delsparsepy/delsparse_src}/real_precision.f90 (100%) rename {src => extras/delsparsepy/delsparse_src}/slatec.f (98%) mode change 100644 => 100755 rename {python => extras/delsparsepy}/example.py (100%) create mode 100755 src/delsparsep create mode 100755 src/delsparses rename src/{ => dependencies}/blas.f (100%) rename src/{ => dependencies}/lapack.f (100%) create mode 100644 src/dependencies/slatec.f create mode 100755 test/test_bin.sh create mode 100644 test/test_c_install.c rename {src => test}/test_install.f90 (100%) rename {src => toms1012}/LICENSE (100%) rename {src => toms1012}/Makefile (100%) rename {src => toms1012}/README (100%) create mode 100644 toms1012/blas.f create mode 100644 toms1012/delsparse.f90 create mode 100644 toms1012/lapack.f create mode 100644 toms1012/sample_input2d.dat create mode 100644 toms1012/sample_input4d.dat create mode 100644 toms1012/samplep.f90 create mode 100644 toms1012/samples.f90 rename {c_binding => toms1012}/slatec.f (100%) create mode 100644 toms1012/test_install.f90 diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..e8f0af6 --- /dev/null +++ b/Makefile @@ -0,0 +1,110 @@ +# Your Fortran 2003 compliant compiler. Must support C bindings to build +# delsparsec library (in extras/c_binding). +FORT = gfortran + +# Set the prefix for your install directory. Installs in-place by default. +PREFIX = $(PWD) + +# Compiler flags defined below. + +# Build without linking +CFLAGS = -c + +# $OPTS must contain the flag for building OpenMP threadsafe (-fopenmp on GNU). +# You can add additional flags (such as -O3) for code optimization +OPTS = -fopenmp -O3 -fPIC + +# Link shared objects +LFLAGS = -shared + +# Legacy flag, used for suppressing warnings when building SLATEC +LEGACY = -std=legacy + +# Dependencies: Replace with appropriate linker flag (e.g., -llapack -lblas) +# if you have these libraries already installed on your computer. +# Otherwise, the value below will use the included minimal copies, taken +# from the public domain. +# Note that there is a known issue that occurs during extrapolation when +# linking against the public version of lapack.f. +LIBS = dependencies/lapack.f dependencies/blas.f + + +# Build formula: + +# Make all library/module files + +all: src/libdelsparse.so src/delsparses src/delsparsep extras/c_binding/libdelsparsec.so + +# Copy all libraries, module files, and binaries into their install locations + +install: include bin lib + cp src/libdelsparse.so $(PREFIX)/lib/libdelsparse.so + cp src/delsparse_mod.mod $(PREFIX)/include/delsparse_mod.mod + cp src/real_precision.mod $(PREFIX)/include/real_precision.mod + cp src/delsparses $(PREFIX)/bin/delsparses + cp src/delsparsep $(PREFIX)/bin/delsparsep + cp extras/c_binding/libdelsparsec.so $(PREFIX)/lib/libdelsparsec.so + cp extras/c_binding/delsparse.h $(PREFIX)/include/delsparse.h + +# Test installation + +test_install: test/test_install.f90 test/test_c_install.c include/delsparse_mod.mod include/delsparse.h lib/libdelsparse.so lib/libdelsparsec.so bin/delsparses bin/delsparsep + $(FORT) $(OPTS) test/test_install.f90 -I$(PREFIX)/include -L$(PREFIX)/lib -ldelsparse -o test/test_install + export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH):$(PREFIX)/lib && test/test_install + $(FORT) $(OPTS) test/test_c_install.c -I$(PREFIX)/include -L$(PREFIX)/lib -ldelsparsec -o test/test_c_install + export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH):$(PREFIX)/lib && test/test_c_install + test/test_bin.sh + +# Make shared libs + +extras/c_binding/libdelsparsec.so: src/dependencies/slatec.o extras/c_binding/delsparsec.o + cp src/dependencies/slatec.o extras/c_binding/dependencies/slatec.o + cd extras/c_binding && $(FORT) $(LFLAGS) $(OPTS) delsparsec.o delsparse.o dependencies/slatec.o $(LIBS) -o libdelsparsec.so + +src/libdelsparse.so: src/dependencies/slatec.o src/delsparse.o + cd src && $(FORT) $(LFLAGS) $(OPTS) delsparse.o dependencies/slatec.o $(LIBS) -o libdelsparse.so + +# Make bin execs + +src/delsparses: src/samples.f90 src/delsparse.o src/dependencies/slatec.o + cd src && $(FORT) $(OPTS) samples.f90 delsparse.o dependencies/slatec.o $(LIBS) -o delsparses + +src/delsparsep: src/samplep.f90 src/delsparse.o src/dependencies/slatec.o + cd src && $(FORT) $(OPTS) samplep.f90 delsparse.o dependencies/slatec.o $(LIBS) -o delsparsep + +# Make C bindings + +extras/c_binding/delsparsec.o: extras/c_binding/delsparse_bind_c.f90 + cd extras/c_binding && $(FORT) $(CFLAGS) $(OPTS) delsparse.f90 -o delsparse.o + cd extras/c_binding && $(FORT) $(CFLAGS) $(OPTS) delsparse_bind_c.f90 -o delsparsec.o + +# Make delsparse.o and slatec.o + +src/delsparse.o: src/delsparse.f90 + cd src && $(FORT) $(CFLAGS) $(OPTS) delsparse.f90 -o delsparse.o + +src/dependencies/slatec.o : src/dependencies/slatec.f + cd src/dependencies && $(FORT) $(CFLAGS) $(OPTS) $(LEGACY) slatec.f -o slatec.o + +# Make install directories + +include: + mkdir include + +lib: + mkdir lib + +bin: + mkdir bin + +# Clean command + +clean: + cd src && rm -f *.o *.mod *.so + cd src/dependencies && rm -f *.o + cd extras/c_binding && rm -f *.o *.mod *.so + cd extras/c_binding/dependencies && rm -f *.o + cd lib && rm -f *.so + cd bin && rm -f delsparses delsparsep + cd include && rm -f delsparse.h *.mod + cd test && rm -f test_install test_c_install diff --git a/README.md b/README.md index 3bfe1a5..e3c6be3 100644 --- a/README.md +++ b/README.md @@ -7,29 +7,62 @@ Delaunay triangulation. In addition to the original Fortran source code, this repository contains a wrapper for Python 3.6+ and C bindings. Command line drivers are also provided with the original Fortran code. -## Organization and Usage +## Usage -The physical organization is as follows. Note that each of the following -directories could be independently downloaded. +`DELAUNAYSPARSE` contains several modes of operation. - * `src` contains the original unmodified Fortran source code, as published - in ACM TOMS Algorithm 1012. This includes 2 command line drivers +At the most basic level, the two driver subroutines are as follows. + * `DELAUNAYSPARSES` runs the serial driver to identify the vertices + of the simplex/simplices containing one or more interpolation points. + Can also (optionally) be set to compute and return the value of the + Delaunay interpolant. + * `DELAUNAYSPARSEP` runs the parallel driver to identify the vertices + of the simplex/simplices containing one or more interpolation points. + Can also (optionally) be set to compute and return the value of the + Delaunay interpolant (must set the `OMP_NUM_THREADS` environment + variable). + +Additionally, two command-line drivers are provided, which read input +from files: + * `delsparses` (uses the serial driver), and + * `delsparsep` (uses the parallel driver). + +In the `extras` directory, there are two additional interfaces for calling +from C/C++ (`extras/c_binding`) and Python 3 (`extras/delsparsepy`). + +Further detailed user information is documented in the USAGE document. + +## Organization + +The physical organization is as follows. + + * `toms1012` contains the original unmodified Fortran source code, as + published in ACM TOMS Algorithm 1012. This includes 2 command line drivers `samples.f90` (serial driver) and `samplep.f90` (parallel driver), which can be used on formatted data files from the command line. Comments at the top of each subroutine document their usage. See this directory's internal README for further information on - building, testing, and usage. - * `python` contains a Python3 wrapper for the Fortran code, allowing - DELAUNAYSPARSE to be directly imported as a Python package. This wrapper - was created by modifying the output generated by fmodpy. The script - `example.py` demonstrates its usage. For convenience, copies of all - Fortran code that is used by the Python wrapper are also included in - this directory. - * `c_binding` contains C bindings for several variations of the main - Fortran subroutines, as well as copies of the Fortran source code. - A test file `test_install.c` can be used for usage examples. This - directory's internal README also contains best practices when calling - Fortran from C/C++. + building, testing, and usage. The directory can be independently + downloaded and is fully portable. + * `src` contains the latest project source, which has been configured + to easily install using modern package managers. + * `test` contains basic regression test cases for each major mode of + operation, so that the installation can be tested. + * `data` contains several real-world data files (exhibiting degeneracy), + for testing the installation and providing a sample for the CL interface. + * `extras` contains the C bindings (`c_binding`) and DelaunaySparse for + Python (`delsparsepy`). For convenience, copies of all source code and + dependencies are duplicated in each of these directories. + * A GNU Makefile is provided for building, installing, and running tests. + Define your Fortran compiler and options at the top of the file, and + (optionally) set the install directory by setting the $(PREFIX) variable. + Then use `make` to build binaries, `make install` to install binaries, + and `make test_install` to test the installation. + Binary executables will install in `$(PREFIX)/bin`, headers will install + to `$(PREFIX)/include`, and shared libraries will install to + `$(PREFIX)/lib`. Running these commands also builds/installs/tests the + C interface, `delsparsec`. The Python extras must be installed separately. + * USAGE provides additional detailed user information. ## Citation diff --git a/USAGE b/USAGE new file mode 100644 index 0000000..c395684 --- /dev/null +++ b/USAGE @@ -0,0 +1,549 @@ +# Usage Information for using DELAUNAYSPARSE. + +DELAUNAYSPARSE solves the multivariate interpolation problem: + +Given a set of `N` points `PTS` and a set of `M` interpolation points +`Q` in `R^D`, for each interpolation point `Q_i` in `Q`, identify the set +of `D+1` data points in `PTS` that are the vertices of a Delaunay simplex +containing `Q_i`. + +These vertices can be used to calculate the Delaunay interpolant using +a piecewise linear model. + +For more information on the underlying algorithm, see + +Chang et al. 2018. A polynomial time algorithm for multivariate interpolation +in arbitrary dimension via the Delaunay triangulation. In Proc. ACMSE 2018 +Conference. + +For more information on this software, see + +Chang et al. 2020. Algorithm 1012: DELAUNAYSPARSE: Interpolation via a sparse +subset of the Delaunay triangulation in medium to high dimensions. +ACM Trans. Math. Softw. 46(4). Article No. 38. + +DELAUNAYSPARSE contains a Fortran module + * `delsparse`; + +as well as C bindings + * `delsparsec`; + +two command-line drivers + * `delsparses` and + * `delsparsep`; + +and a Python 3 wrapper + * `delsparsepy`. + +These interfaces are described in the following sections. + +## Fortran interface + +DELAUNAYSPARSE is written in Fortran 2003, and this is its native interface. +The Fortran interface contains two drivers: + * `DELAUNAYSPARSES` (serial driver) and + * `DELAUNAYSPARSEP` (OpenMP parallel driver). + +### DELAUNAYSPARSES + +The interface for DELAUNAYSPARSES is + +``` +SUBROUTINE DELAUNAYSPARSES( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, & + IBUDGET, CHAIN, EXACT ) +``` + +Each of the above parameters is described below. + + +On input: + + * `D` is the dimension of the space for `PTS` and `Q`. + + * N is the number of data points in PTS. + + * PTS(1:D,1:N) is a real valued matrix with N columns, each containing the + coordinates of a single data point in R^D. + + * M is the number of interpolation points in Q. + + * Q(1:D,1:M) is a real valued matrix with M columns, each containing the + coordinates of a single interpolation point in R^D. + + +On output: + + * `PTS` and `Q` have been rescaled and shifted. All the data points in `PTS` + are now contained in the unit hyperball in R^D, and the points in `Q` + have been shifted and scaled accordingly in relation to `PTS`. + + * `SIMPS(1:D+1,1:M)` contains the `D+1` integer indices (corresponding to + columns in `PTS`) for the `D+1` vertices of the Delaunay simplex + containing each interpolation point in `Q`. + + * `WEIGHTS(1:D+1,1:M)` contains the `D+1` real-valued weights for expressing + each point in `Q` as a convex combination of the `D+1` corresponding vertices + in `SIMPS`. + + * `IERR(1:M)` contains integer valued error flags associated with the + computation of each of the `M` interpolation points in `Q`. The error + codes are: + + Codes 0, 1, 2 are expected to occur during normal execution. + + - 00 : Succesful interpolation. + - 01 : Succesful extrapolation (up to the allowed extrapolation distance). + - 02 : This point was outside the allowed extrapolation distance; the + corresponding entries in SIMPS and WEIGHTS contain zero values. + + Error codes 10--28 indicate that one or more inputs contain illegal + values or are incompatible with each other. + + - 10 : The dimension D must be positive. + - 11 : Too few data points to construct a triangulation (i.e., N < D+1). + - 12 : No interpolation points given (i.e., M < 1). + - 13 : The first dimension of PTS does not agree with the dimension D. + - 14 : The second dimension of PTS does not agree with the number of + points N. + - 15 : The first dimension of Q does not agree with the dimension D. + - 16 : The second dimension of Q does not agree with the number of + interpolation points M. + - 17 : The first dimension of the output array SIMPS does not match the + number of vertices needed for a D-simplex (D+1). + - 18 : The second dimension of the output array SIMPS does not match the + number of interpolation points M. + - 19 : The first dimension of the output array WEIGHTS does not match the + number of vertices for a a D-simplex (D+1). + - 20 : The second dimension of the output array WEIGHTS does not match the + number of interpolation points M. + - 21 : The size of the error array IERR does not match the number of + interpolation points M. + - 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. + - 23 : The first dimension of INTERP_IN does not match the first + dimension of INTERP_OUT. + - 24 : The second dimension of INTERP_IN does not match the number of + data points PTS. + - 25 : The second dimension of INTERP_OUT does not match the number of + interpolation points M. + - 26 : The budget supplied in IBUDGET does not contain a positive + integer. + - 27 : The extrapolation distance supplied in EXTRAP cannot be negative. + - 28 : The size of the RNORM output array does not match the number of + interpolation points M. + + The errors 30, 31 typically indicate that DELAUNAYSPARSE has been given + an unclean dataset. These errors can be fixed by preprocessing your + data (remove duplicate points and apply PCA or other dimension reduction + technique). + + - 30 : Two or more points in the data set PTS are too close together with + respect to the working precision (EPS), which would result in a + numerically degenerate simplex. + - 31 : All the data points in PTS lie in some lower dimensional linear + manifold (up to the working precision), and no valid triangulation + exists. + + The error code 40 occurs when another earlier error prevented this point + from ever being evaluated. + + - 40 : An error caused DELAUNAYSPARSES to terminate before this value + could be computed. Note: The corresponding entries in SIMPS and + WEIGHTS may contain garbage values. + + The error code 50 corresponds to allocation of the internal WORK array. + Check your systems internal memory settings and limits, in relation + to the problem size and DELAUNAYSPARSE's space requirements (see TOMS + Alg. paper for more details on DELAUNAYSPARSE's space requirements). + + - 50 : A memory allocation error occurred while allocating the work array + WORK. + + The errors 60, 61 should not occur with the default settings. If one of + these errors is observed, then it is likely that either the value of + the optional inputs IBUDGET or EPS has been adjusted in a way that is + unwise, or there may be another issue with the problem settings, which + is manifesting in an unusual way. + + - 60 : The budget was exceeded before the algorithm converged on this + value. If the dimension is high, try increasing IBUDGET. This + error can also be caused by a working precision EPS that is too + small for the conditioning of the problem. + - 61 : A value that was judged appropriate later caused LAPACK to + encounter a singularity. Try increasing the value of EPS. + + The errors 70--72 were caused by the DWNNLS library from SLATEC, which + is only used during extrapolation. Note that there is a known issue + with this library, when it is linked against included public-domain + copy of BLAS/LAPACK, instead of an installed version + (i.e., -lblas -llapack). + + - 70 : Allocation error for the extrapolation work arrays. + - 71 : The SLATEC subroutine DWNNLS failed to converge during the + projection of an extrapolation point onto the convex hull. + - 72 : The SLATEC subroutine DWNNLS has reported a usage error. + + The errors 72, 80--83 should never occur, and likely indicate a + compiler bug or hardware failure. + + - 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. + - 81 : The LAPACK subroutine DGETRF has reported an illegal value. + - 82 : The LAPACK subroutine DGETRS has reported an illegal value. + - 83 : The LAPACK subroutine DORMQR has reported an illegal value. + + +Optional arguments: + + * INTERP_IN(1:IR,1:N) contains real valued response vectors for each of + the data points in PTS on input. The first dimension of INTERP_IN is + inferred to be the dimension of these response vectors, and the + second dimension must match N. If present, the response values will + be computed for each interpolation point in Q, and stored in INTERP_OUT, + which therefore must also be present. If both INTERP_IN and INTERP_OUT + are omitted, only the containing simplices and convex combination + weights are returned. + + * INTERP_OUT(1:IR,1:M) contains real valued response vectors for each + interpolation point in Q on output. The first dimension of INTERP_OUT + must match the first dimension of INTERP_IN, and the second dimension + must match M. If present, the response values at each interpolation + point are computed as a convex combination of the response values + (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing + that interpolation point. Therefore, if INTERP_OUT is present, then + INTERP_IN must also be present. If both are omitted, only the + simplices and convex combination weights are returned. + + * EPS contains the real working precision for the problem on input. By + default, EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff + for the machine. In general, any values that differ by less than EPS + are judged as equal, and any weights that are greater than -EPS are + judged as nonnegative. EPS cannot take a value less than the default + value of \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, + the default value will be used instead automatically. + + * EXTRAP contains the real maximum extrapolation distance (relative to the + diameter of PTS) on input. Interpolation at a point outside the convex + hull of PTS is done by projecting that point onto the convex hull, and + then doing normal Delaunay interpolation at that projection. + Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) + units outside the convex hull of PTS will not be done and an error code + of 2 will be returned. Note that computing the projection can be + expensive. Setting EXTRAP=0 will cause all extrapolation points to be + ignored without ever computing a projection. By default, EXTRAP=0.1 + (extrapolate by up to 10% of the diameter of PTS). + + * RNORM(1:M) contains the real unscaled projection (2-norm) distances from + any projection computations on output. If not present, these distances + are still computed for each extrapolation point, but are never returned. + + * IBUDGET on input contains the integer budget for performing flips while + iterating toward the simplex containing each interpolation point in + Q. This prevents DELAUNAYSPARSES from falling into an infinite loop when + an inappropriate value of EPS is given with respect to the problem + conditioning. By default, IBUDGET=50000. However, for extremely + high-dimensional problems and pathological inputs, the default value + may be insufficient. + + * CHAIN is a logical input argument that determines whether a new first + simplex should be constructed for each interpolation point + (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." + By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not + recommended, unless the size of the triangulation is relatively small + or the interpolation points are known to be tightly clustered. + + * EXACT is a logical input argument that determines whether the exact + diameter should be computed and whether a check for duplicate data + points should be performed in advance. When EXACT=.FALSE., the + diameter of PTS is approximated by twice the distance from the + barycenter of PTS to the farthest point in PTS, and no check is + done to find the closest pair of points, which could result in hard + to find bugs later on. When EXACT=.TRUE., the exact diameter is + computed and an error is returned whenever PTS contains duplicate + values up to the precision EPS. By default EXACT=.TRUE., but setting + EXACT=.FALSE. could result in significant speedup when N is large. + It is strongly recommended that most users leave EXACT=.TRUE., as + setting EXACT=.FALSE. could result in input errors that are difficult + to identify. Also, the diameter approximation could be wrong by up to + a factor of two. + + +Subroutines and functions directly referenced from BLAS are + * `DDOT`, + * `DGEMV`, + * `DNRM2`, + * `DTRSM`, +and from LAPACK are + * `DGEQP3`, + * `DGETRF`, + * `DGETRS`, + * `DORMQR`. + +The SLATEC subroutine + * `DWNNLS` is also directly referenced. + +`DWNNLS` and all its SLATEC dependencies have been slightly edited to +comply with the Fortran 2008 standard, with all print statements and +references to stderr being commented out. For a reference to `DWNNLS`, +see ACM TOMS Algorithm 587 (Hanson and Haskell). +The module `REAL_PRECISION` from HOMPACK90 (ACM TOMS Algorithm 777) is +used for the real data type. The `REAL_PRECISION` module, `DELAUNAYSPARSES`, +and `DWNNLS` and its dependencies comply with the Fortran 2008 standard. + +## DELAUNAYSPARSEP + +``` +SUBROUTINE DELAUNAYSPARSEP( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EXACT, & + PMODE ) +``` + +Each of the above parameters is described below. + + +On input: + + * `D` is the dimension of the space for `PTS` and `Q`. + + * N is the number of data points in PTS. + + * PTS(1:D,1:N) is a real valued matrix with N columns, each containing the + coordinates of a single data point in R^D. + + * M is the number of interpolation points in Q. + + * Q(1:D,1:M) is a real valued matrix with M columns, each containing the + coordinates of a single interpolation point in R^D. + + +On output: + + * `PTS` and `Q` have been rescaled and shifted. All the data points in `PTS` + are now contained in the unit hyperball in R^D, and the points in `Q` + have been shifted and scaled accordingly in relation to `PTS`. + + * `SIMPS(1:D+1,1:M)` contains the `D+1` integer indices (corresponding to + columns in `PTS`) for the `D+1` vertices of the Delaunay simplex + containing each interpolation point in `Q`. + + * `WEIGHTS(1:D+1,1:M)` contains the `D+1` real-valued weights for expressing + each point in `Q` as a convex combination of the `D+1` corresponding vertices + in `SIMPS`. + + * `IERR(1:M)` contains integer valued error flags associated with the + computation of each of the `M` interpolation points in `Q`. The error + codes are: + + Codes 0, 1, 2 are expected to occur during normal execution. + + - 00 : Succesful interpolation. + - 01 : Succesful extrapolation (up to the allowed extrapolation distance). + - 02 : This point was outside the allowed extrapolation distance; the + corresponding entries in SIMPS and WEIGHTS contain zero values. + + Error codes 10--28 indicate that one or more inputs contain illegal + values or are incompatible with each other. + + - 10 : The dimension D must be positive. + - 11 : Too few data points to construct a triangulation (i.e., N < D+1). + - 12 : No interpolation points given (i.e., M < 1). + - 13 : The first dimension of PTS does not agree with the dimension D. + - 14 : The second dimension of PTS does not agree with the number of + points N. + - 15 : The first dimension of Q does not agree with the dimension D. + - 16 : The second dimension of Q does not agree with the number of + interpolation points M. + - 17 : The first dimension of the output array SIMPS does not match the + number of vertices needed for a D-simplex (D+1). + - 18 : The second dimension of the output array SIMPS does not match the + number of interpolation points M. + - 19 : The first dimension of the output array WEIGHTS does not match the + number of vertices for a a D-simplex (D+1). + - 20 : The second dimension of the output array WEIGHTS does not match the + number of interpolation points M. + - 21 : The size of the error array IERR does not match the number of + interpolation points M. + - 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. + - 23 : The first dimension of INTERP_IN does not match the first + dimension of INTERP_OUT. + - 24 : The second dimension of INTERP_IN does not match the number of + data points PTS. + - 25 : The second dimension of INTERP_OUT does not match the number of + interpolation points M. + - 26 : The budget supplied in IBUDGET does not contain a positive + integer. + - 27 : The extrapolation distance supplied in EXTRAP cannot be negative. + - 28 : The size of the RNORM output array does not match the number of + interpolation points M. + + The errors 30, 31 typically indicate that DELAUNAYSPARSE has been given + an unclean dataset. These errors can be fixed by preprocessing your + data (remove duplicate points and apply PCA or other dimension reduction + technique). + + - 30 : Two or more points in the data set PTS are too close together with + respect to the working precision (EPS), which would result in a + numerically degenerate simplex. + - 31 : All the data points in PTS lie in some lower dimensional linear + manifold (up to the working precision), and no valid triangulation + exists. + + The error code 40 occurs when another earlier error prevented this point + from ever being evaluated. + + - 40 : An error caused DELAUNAYSPARSES to terminate before this value + could be computed. Note: The corresponding entries in SIMPS and + WEIGHTS may contain garbage values. + + The error code 50 corresponds to allocation of the internal WORK array. + Check your systems internal memory settings and limits, in relation + to the problem size and DELAUNAYSPARSE's space requirements (see TOMS + Alg. paper for more details on DELAUNAYSPARSE's space requirements). + + - 50 : A memory allocation error occurred while allocating the work array + WORK. + + The errors 60, 61 should not occur with the default settings. If one of + these errors is observed, then it is likely that either the value of + the optional inputs IBUDGET or EPS has been adjusted in a way that is + unwise, or there may be another issue with the problem settings, which + is manifesting in an unusual way. + + - 60 : The budget was exceeded before the algorithm converged on this + value. If the dimension is high, try increasing IBUDGET. This + error can also be caused by a working precision EPS that is too + small for the conditioning of the problem. + - 61 : A value that was judged appropriate later caused LAPACK to + encounter a singularity. Try increasing the value of EPS. + + The errors 70--72 were caused by the DWNNLS library from SLATEC, which + is only used during extrapolation. Note that there is a known issue + with this library, when it is linked against included public-domain + copy of BLAS/LAPACK, instead of an installed version + (i.e., -lblas -llapack). + + - 70 : Allocation error for the extrapolation work arrays. + - 71 : The SLATEC subroutine DWNNLS failed to converge during the + projection of an extrapolation point onto the convex hull. + - 72 : The SLATEC subroutine DWNNLS has reported a usage error. + + The errors 72, 80--83 should never occur, and likely indicate a + compiler bug or hardware failure. + + - 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. + - 81 : The LAPACK subroutine DGETRF has reported an illegal value. + - 82 : The LAPACK subroutine DGETRS has reported an illegal value. + - 83 : The LAPACK subroutine DORMQR has reported an illegal value. + + The error code 90 is unique to DELAUNAYSPARSEP. + + - 90 : The value of PMODE is not valid. + + +Optional arguments: + + * INTERP_IN(1:IR,1:N) contains real valued response vectors for each of + the data points in PTS on input. The first dimension of INTERP_IN is + inferred to be the dimension of these response vectors, and the + second dimension must match N. If present, the response values will + be computed for each interpolation point in Q, and stored in INTERP_OUT, + which therefore must also be present. If both INTERP_IN and INTERP_OUT + are omitted, only the containing simplices and convex combination + weights are returned. + + * INTERP_OUT(1:IR,1:M) contains real valued response vectors for each + interpolation point in Q on output. The first dimension of INTERP_OUT + must match the first dimension of INTERP_IN, and the second dimension + must match M. If present, the response values at each interpolation + point are computed as a convex combination of the response values + (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing + that interpolation point. Therefore, if INTERP_OUT is present, then + INTERP_IN must also be present. If both are omitted, only the + simplices and convex combination weights are returned. + + * EPS contains the real working precision for the problem on input. By + default, EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff + for the machine. In general, any values that differ by less than EPS + are judged as equal, and any weights that are greater than -EPS are + judged as nonnegative. EPS cannot take a value less than the default + value of \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, + the default value will be used instead automatically. + + * EXTRAP contains the real maximum extrapolation distance (relative to the + diameter of PTS) on input. Interpolation at a point outside the convex + hull of PTS is done by projecting that point onto the convex hull, and + then doing normal Delaunay interpolation at that projection. + Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) + units outside the convex hull of PTS will not be done and an error code + of 2 will be returned. Note that computing the projection can be + expensive. Setting EXTRAP=0 will cause all extrapolation points to be + ignored without ever computing a projection. By default, EXTRAP=0.1 + (extrapolate by up to 10% of the diameter of PTS). + + * RNORM(1:M) contains the real unscaled projection (2-norm) distances from + any projection computations on output. If not present, these distances + are still computed for each extrapolation point, but are never returned. + + * IBUDGET on input contains the integer budget for performing flips while + iterating toward the simplex containing each interpolation point in + Q. This prevents DELAUNAYSPARSES from falling into an infinite loop when + an inappropriate value of EPS is given with respect to the problem + conditioning. By default, IBUDGET=50000. However, for extremely + high-dimensional problems and pathological inputs, the default value + may be insufficient. + + * CHAIN is a logical input argument that determines whether a new first + simplex should be constructed for each interpolation point + (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." + By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not + recommended, unless the size of the triangulation is relatively small + or the interpolation points are known to be tightly clustered. + + * EXACT is a logical input argument that determines whether the exact + diameter should be computed and whether a check for duplicate data + points should be performed in advance. When EXACT=.FALSE., the + diameter of PTS is approximated by twice the distance from the + barycenter of PTS to the farthest point in PTS, and no check is + done to find the closest pair of points, which could result in hard + to find bugs later on. When EXACT=.TRUE., the exact diameter is + computed and an error is returned whenever PTS contains duplicate + values up to the precision EPS. By default EXACT=.TRUE., but setting + EXACT=.FALSE. could result in significant speedup when N is large. + It is strongly recommended that most users leave EXACT=.TRUE., as + setting EXACT=.FALSE. could result in input errors that are difficult + to identify. Also, the diameter approximation could be wrong by up to + a factor of two. + + * PMODE is an integer specifying the level of parallelism to be exploited. + If PMODE = 1, then parallelism is exploited at the level of the loop + over all interpolation points (Level 1 parallelism). + If PMODE = 2, then parallelism is exploited at the level of the loops + over data points when constructing/flipping simplices (Level 2 + parallelism). + If PMODE = 3, then parallelism is exploited at both levels. Note: this + implies that the total number of threads active at any time could be up + to OMP_NUM_THREADS^2. + By default, PMODE is set to 1 if there is more than 1 interpolation + point and 2 otherwise. + + +Subroutines and functions directly referenced from BLAS are + * `DDOT`, + * `DGEMV`, + * `DNRM2`, + * `DTRSM`, +and from LAPACK are + * `DGEQP3`, + * `DGETRF`, + * `DGETRS`, + * `DORMQR`. + +The SLATEC subroutine + * `DWNNLS` is also directly referenced. + +`DWNNLS` and all its SLATEC dependencies have been slightly edited to +comply with the Fortran 2008 standard, with all print statements and +references to stderr being commented out. For a reference to `DWNNLS`, +see ACM TOMS Algorithm 587 (Hanson and Haskell). +The module `REAL_PRECISION` from HOMPACK90 (ACM TOMS Algorithm 777) is +used for the real data type. The `REAL_PRECISION` module, `DELAUNAYSPARSES`, +and `DWNNLS` and its dependencies comply with the Fortran 2008 standard. diff --git a/src/sample_input2d.dat b/data/varsys/sample_input2d.dat similarity index 100% rename from src/sample_input2d.dat rename to data/varsys/sample_input2d.dat diff --git a/src/sample_input4d.dat b/data/varsys/sample_input4d.dat similarity index 100% rename from src/sample_input4d.dat rename to data/varsys/sample_input4d.dat diff --git a/c_binding/LICENSE b/extras/c_binding/LICENSE similarity index 100% rename from c_binding/LICENSE rename to extras/c_binding/LICENSE diff --git a/c_binding/Makefile b/extras/c_binding/Makefile similarity index 52% rename from c_binding/Makefile rename to extras/c_binding/Makefile index bc04468..937fc4d 100644 --- a/c_binding/Makefile +++ b/extras/c_binding/Makefile @@ -2,10 +2,11 @@ FORT = gfortran CC = gcc CFLAGS = -c OPTS = -fopenmp +LIBS = dependencies/blas.f dependencies/lapack.f LEGACY = -std=legacy -all: test_install.o delsparse_bind_c.o delsparse.o slatec.o lapack.o blas.o - $(FORT) $(OPTS) test_install.o delsparse_bind_c.o delsparse.o slatec.o lapack.o blas.o -o test_install +all: test_install.o delsparse_bind_c.o delsparse.o dependencies/slatec.o delsparse.h + $(FORT) $(OPTS) test_install.o delsparse_bind_c.o delsparse.o dependencies/slatec.o $(LIBS) -o test_install ./test_install test_install.o: test_install.c @@ -17,14 +18,8 @@ delsparse_bind_c.o: delsparse_bind_c.f90 delsparse.o delsparse.o: delsparse.f90 $(FORT) $(CFLAGS) $(OPTS) delsparse.f90 -o delsparse.o -slatec.o : slatec.f - $(FORT) $(CFLAGS) $(OPTS) $(LEGACY) slatec.f -o slatec.o - -lapack.o : lapack.f - $(FORT) $(CFLAGS) $(OPTS) lapack.f -o lapack.o - -blas.o : blas.f - $(FORT) $(CFLAGS) $(OPTS) blas.f -o blas.o +dependencies/slatec.o : dependencies/slatec.f + cd dependencies && $(FORT) $(CFLAGS) $(OPTS) $(LEGACY) slatec.f -o slatec.o clean: rm -f *.o *.mod test_install diff --git a/c_binding/README b/extras/c_binding/README similarity index 100% rename from c_binding/README rename to extras/c_binding/README diff --git a/c_binding/delsparse.f90 b/extras/c_binding/delsparse.f90 similarity index 100% rename from c_binding/delsparse.f90 rename to extras/c_binding/delsparse.f90 diff --git a/extras/c_binding/delsparse.h b/extras/c_binding/delsparse.h new file mode 100644 index 0000000..4ed0241 --- /dev/null +++ b/extras/c_binding/delsparse.h @@ -0,0 +1,59 @@ +#ifndef DELSPARSEC +#define DELSPARSEC + +// serial subroutine: no optional arguments +extern void c_delaunaysparses(int *d, int *n, double pts[], int *m, double q[], + int simps[], double weights[], int ierr[]); + +// serial: compute interpolant values +extern void c_delaunaysparses_interp(int *d, int *n, double pts[], int *m, + double q[], int simps[], double weights[], + int ierr[], int *ir, double interp_in[], + double interp_out[]); + +// serial: optional arguments, no interpolant values +extern void c_delaunaysparses_opts(int *d, int *n, double pts[], int *m, + double q[],int simps[], double weights[], + int ierr[], double *eps, double *extrap, + double rnorm[], int *ibudget, bool *chain, + bool *exact); + +// serial: optional arguments and compute interpolant values +extern void c_delaunaysparses_interp_opts(int *d, int *n, double pts[], int *m, + double q[],int simps[], + double weights[], int ierr[], + int *ir, double interp_in[], + double interp_out[], double *eps, + double *extrap, double rnorm[], + int *ibudget, bool *chain, + bool *exact); + + +// parallel: no optional arguments +extern void c_delaunaysparsep(int *d, int *n, double pts[], int *m, double q[], + int simps[], double weights[], int ierr[]); + +// parallel: compute interpolant values +extern void c_delaunaysparsep_interp(int *d, int *n, double pts[], int *m, + double q[], int simps[], double weights[], + int ierr[], int *ir, double interp_in[], + double interp_out[]); + +// parallel: optional arguments, no interpolant values +extern void c_delaunaysparsep_opts(int *d, int *n, double pts[], int *m, + double q[],int simps[], double weights[], + int ierr[], double *eps, double *extrap, + double rnorm[], int *ibudget, bool *chain, + bool *exact, int *pmode); + +// parallel: optional arguments and compute interpolant values +extern void c_delaunaysparsep_interp_opts(int *d, int *n, double pts[], int *m, + double q[],int simps[], + double weights[], int ierr[], + int *ir, double interp_in[], + double interp_out[], double *eps, + double *extrap, double rnorm[], + int *ibudget, bool *chain, + bool *exact, int *pmode); + +#endif diff --git a/c_binding/delsparse_bind_c.f90 b/extras/c_binding/delsparse_bind_c.f90 similarity index 100% rename from c_binding/delsparse_bind_c.f90 rename to extras/c_binding/delsparse_bind_c.f90 diff --git a/c_binding/blas.f b/extras/c_binding/dependencies/blas.f similarity index 100% rename from c_binding/blas.f rename to extras/c_binding/dependencies/blas.f diff --git a/c_binding/lapack.f b/extras/c_binding/dependencies/lapack.f similarity index 100% rename from c_binding/lapack.f rename to extras/c_binding/dependencies/lapack.f diff --git a/python/slatec.f b/extras/c_binding/dependencies/slatec.f old mode 100755 new mode 100644 similarity index 98% rename from python/slatec.f rename to extras/c_binding/dependencies/slatec.f index 7d51578..c652a26 --- a/python/slatec.f +++ b/extras/c_binding/dependencies/slatec.f @@ -7,7 +7,7 @@ SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, C a covariance matrix. C***LIBRARY SLATEC C***CATEGORY K1A2A, D9 -C***TYPE REAL(KIND=R8) (LSEI-S, DLSEI-D) +C***TYPE DOUBLE PRECISION (LSEI-S, DLSEI-D) C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, C QUADRATIC PROGRAMMING @@ -62,7 +62,7 @@ SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, C C The parameters for DLSEI( ) are C -C Input.. All TYPE REAL variables are REAL(KIND=R8) +C Input.. All TYPE REAL variables are DOUBLE PRECISION C C W(*,*),MDW, The array W(*,*) is doubly subscripted with C ME,MA,MG,N first dimensioning parameter equal to MDW. @@ -268,7 +268,7 @@ SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, C LIP = MG+2*N+2 C This test will not be made if IP(2).LE.0. C -C Output.. All TYPE REAL variables are REAL(KIND=R8) +C Output.. All TYPE REAL variables are DOUBLE PRECISION C C X(*),RNORME, The array X(*) contains the solution parameters C RNORML if the integer output flag MODE = 0 or 1. @@ -382,18 +382,17 @@ SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, C 900510 Convert XERRWV calls to XERMSG calls. (RWC) C 900604 DP version created from SP version. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Removed prints and replaced DP --> REAL(KIND=R8). (THC) +C 180613 Removed prints and replaced DP --> DOUBLE PRECISION. (THC) C***END PROLOGUE DLSEI - USE REAL_PRECISION INTEGER IP(3), MA, MDW, ME, MG, MODE, N - REAL(KIND=R8) PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*) + DOUBLE PRECISION PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*) C EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, DNRM2, * DSCAL, DSWAP - REAL(KIND=R8) D1MACH, DASUM, DDOT, DNRM2 + DOUBLE PRECISION D1MACH, DASUM, DDOT, DNRM2 C - REAL(KIND=R8) DRELPR, ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, + DOUBLE PRECISION DRELPR, ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, * SN, SNMAX, T, TAU, UJ, UP, VJ, XNORM, XNRME INTEGER I, IMAX, J, JP1, K, KEY, KRANKE, LAST, LCHK, LINK, M, * MAPKE1, MDEQC, MEND, MEP1, N1, N2, NEXT, NLINK, NOPT, NP1, @@ -743,7 +742,7 @@ SUBROUTINE DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, C***SUBSIDIARY C***PURPOSE Subsidiary to DLSEI C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (LSI-S, DLSI-D) +C***TYPE DOUBLE PRECISION (LSI-S, DLSI-D) C***AUTHOR Hanson, R. J., (SNLA) C***DESCRIPTION C @@ -795,16 +794,15 @@ SUBROUTINE DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, C 900604 DP version created from SP version. (RWC) C 920422 Changed CALL to DHFTI to include variable MA. (WRB) C***END PROLOGUE DLSI - USE REAL_PRECISION INTEGER IP(*), MA, MDW, MG, MODE, N - REAL(KIND=R8) PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*) + DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*) C EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, DLPDP, * DSCAL, DSWAP - REAL(KIND=R8) D1MACH, DASUM, DDOT + DOUBLE PRECISION D1MACH, DASUM, DDOT C - REAL(KIND=R8) ANORM, DRELPR, FAC, GAM, RB, TAU, TOL, XNORM, + DOUBLE PRECISION ANORM, DRELPR, FAC, GAM, RB, TAU, TOL, XNORM, * TMP_NORM(1) INTEGER I, J, K, KEY, KRANK, KRM1, KRP1, L, LAST, LINK, M, MAP1, * MDLPDP, MINMAN, N1, N2, N3, NEXT, NP1 @@ -1079,12 +1077,12 @@ SUBROUTINE DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, RETURN END *DECK D1MACH - REAL(KIND=R8) FUNCTION D1MACH (I) + DOUBLE PRECISION FUNCTION D1MACH (I) C***BEGIN PROLOGUE D1MACH C***PURPOSE Return floating point machine dependent constants. C***LIBRARY SLATEC C***CATEGORY R1 -C***TYPE REAL(KIND=R8) (R1MACH-S, D1MACH-D) +C***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) C***KEYWORDS MACHINE CONSTANTS C***AUTHOR Fox, P. A., (Bell Labs) C Hall, A. D., (Bell Labs) @@ -1151,7 +1149,6 @@ REAL(KIND=R8) FUNCTION D1MACH (I) C comments below. (DWL) C***END PROLOGUE D1MACH C - USE REAL_PRECISION INTEGER SMALL(4) INTEGER LARGE(4) @@ -1164,7 +1161,7 @@ REAL(KIND=R8) FUNCTION D1MACH (I) C for DMACH(2) is a slight lower bound. The value for DMACH(5) is C a 20-digit approximation. If one of the sets of initial data below C is preferred, do the necessary commenting and uncommenting. (DWL) - REAL(KIND=R8) DMACH(5) + DOUBLE PRECISION DMACH(5) DATA DMACH / 2.23D-308, 1.79D+308, 1.111D-16, 2.222D-16, 1 0.30102999566398119521D0 / SAVE DMACH @@ -1387,7 +1384,7 @@ REAL(KIND=R8) FUNCTION D1MACH (I) C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / C C MACHINE CONSTANTS FOR THE ELXSI 6400 -C (ASSUMING REAL*8 IS THE DEFAULT REAL(KIND=R8)) +C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) C C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / @@ -1420,7 +1417,7 @@ REAL(KIND=R8) FUNCTION D1MACH (I) C DATA DMACH(5) / Z'3FD34413509F79FF' / C C MACHINE CONSTANTS FOR THE HP 2100 -C THREE WORD REAL(KIND=R8) OPTION WITH FTN4 +C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / @@ -1429,7 +1426,7 @@ REAL(KIND=R8) FUNCTION D1MACH (I) C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / C C MACHINE CONSTANTS FOR THE HP 2100 -C FOUR WORD REAL(KIND=R8) OPTION WITH FTN4 +C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA SMALL(1), SMALL(2) / 40000B, 0 / C DATA SMALL(3), SMALL(4) / 0, 1 / @@ -1461,7 +1458,7 @@ REAL(KIND=R8) FUNCTION D1MACH (I) C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / C C MACHINE CONSTANTS FOR THE IBM PC -C ASSUMES THAT ALL ARITHMETIC IS DONE IN REAL(KIND=R8) +C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. C C DATA SMALL(1) / 2.23D-308 / @@ -2176,7 +2173,7 @@ INTEGER FUNCTION I1MACH (I) C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE HP 2100 -C 3 WORD REAL(KIND=R8) OPTION WITH FTN4 +C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / @@ -2196,7 +2193,7 @@ INTEGER FUNCTION I1MACH (I) C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE HP 2100 -C 4 WORD REAL(KIND=R8) OPTION WITH FTN4 +C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / @@ -2507,11 +2504,11 @@ SUBROUTINE DH12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV, C***SUBSIDIARY C***PURPOSE Subsidiary to DHFTI, DLSEI and DWNNLS C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (H12-S, DH12-D) +C***TYPE DOUBLE PRECISION (H12-S, DH12-D) C***AUTHOR (UNKNOWN) C***DESCRIPTION C -C *** REAL(KIND=R8) VERSION OF H12 ****** +C *** DOUBLE PRECISION VERSION OF H12 ****** C C C.L.Lawson and R.J.Hanson, Jet Propulsion Laboratory, 1973 Jun 12 C to appear in 'Solving Least Squares Problems', Prentice-Hall, 1974 @@ -2548,13 +2545,12 @@ SUBROUTINE DH12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV, C 890831 Modified array declarations. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) -C 900911 Added DDOT to REAL(KIND=R8) statement. (WRB) +C 900911 Added DDOT to DOUBLE PRECISION statement. (WRB) C***END PROLOGUE DH12 - USE REAL_PRECISION INTEGER I, I2, I3, I4, ICE, ICV, INCR, IUE, J, KL1, KL2, KLP, * L1, L1M1, LPIVOT, M, MML1P2, MODE, NCV - REAL(KIND=R8) B, C, CL, CLINV, ONE, UL1M1, SM, U, UP, DDOT + DOUBLE PRECISION B, C, CL, CLINV, ONE, UL1M1, SM, U, UP, DDOT DIMENSION U(IUE,*), C(*) C BEGIN BLOCK PERMITTING ...EXITS TO 140 C***FIRST EXECUTABLE STATEMENT DH12 @@ -2654,7 +2650,7 @@ SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, C Exactly one right-hand side vector is permitted. C***LIBRARY SLATEC C***CATEGORY D9 -C***TYPE REAL(KIND=R8) (HFTI-S, DHFTI-D) +C***TYPE DOUBLE PRECISION (HFTI-S, DHFTI-D) C***KEYWORDS CURVE FITTING, LEAST SQUARES C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) @@ -2711,7 +2707,7 @@ SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, C C The entire set of parameters for DHFTI are C -C INPUT.. All TYPE REAL variables are REAL(KIND=R8) +C INPUT.. All TYPE REAL variables are DOUBLE PRECISION C C A(*,*),MDA,M,N The array A(*,*) initially contains the M by N C matrix A of the least squares problem AX = B. @@ -2742,7 +2738,7 @@ SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, C C H(*),G(*),IP(*) Arrays of working space used by DHFTI. C -C OUTPUT.. All TYPE REAL variables are REAL(KIND=R8) +C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION C C A(*,*) The contents of the array A(*,*) will be C modified by the subroutine. These contents @@ -2782,11 +2778,10 @@ SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, C 901005 Replace usage of DDIFF with usage of D1MACH. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DHFTI - USE REAL_PRECISION INTEGER I, II, IOPT, IP(*), IP1, J, JB, JJ, K, KP1, KRANK, L, * LDIAG, LMAX, M, MDA, MDB, N, NB, NERR - REAL(KIND=R8) A, B, D1MACH, DZERO, FACTOR, + DOUBLE PRECISION A, B, D1MACH, DZERO, FACTOR, * G, H, HMAX, RELEPS, RNORM, SM, SM1, SZERO, TAU, TMP DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*) SAVE RELEPS @@ -2985,7 +2980,7 @@ SUBROUTINE DLPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, C***SUBSIDIARY C***PURPOSE Subsidiary to DLSEI C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (LPDP-S, DLPDP-D) +C***TYPE DOUBLE PRECISION (LPDP-S, DLPDP-D) C***AUTHOR Hanson, R. J., (SNLA) C Haskell, K. H., (SNLA) C***DESCRIPTION @@ -3028,12 +3023,11 @@ SUBROUTINE DLPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, C 900328 Added TYPE section. (WRB) C 910408 Updated the AUTHOR section. (WRB) C***END PROLOGUE DLPDP - USE REAL_PRECISION C INTEGER I, IS(*), IW, IX, J, L, M, MDA, MODE, MODEW, N, N1, N2, * NP1 - REAL(KIND=R8) A(MDA,*), DDOT, DNRM2, FAC, ONE, + DOUBLE PRECISION A(MDA,*), DDOT, DNRM2, FAC, ONE, * PRGOPT(*), RNORM, SC, WNORM, WS(*), X(*), YNORM, ZERO SAVE ZERO, ONE, FAC DATA ZERO,ONE /0.0D0,1.0D0/, FAC /0.1D0/ @@ -3197,7 +3191,7 @@ SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, C selected variables. C***LIBRARY SLATEC C***CATEGORY K1A2A -C***TYPE REAL(KIND=R8) (WNNLS-S, DWNNLS-D) +C***TYPE DOUBLE PRECISION (WNNLS-S, DWNNLS-D) C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, C NONNEGATIVITY CONSTRAINTS, QUADRATIC PROGRAMMING @@ -3232,7 +3226,7 @@ SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, C C The parameters for DWNNLS are C -C INPUT.. All TYPE REAL variables are REAL(KIND=R8) +C INPUT.. All TYPE REAL variables are DOUBLE PRECISION C C W(*,*),MDW, The array W(*,*) is double subscripted with first C ME,MA,N,L dimensioning parameter equal to MDW. For this @@ -3392,7 +3386,7 @@ SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, C LIW = ME+MA+N C This test will not be made if IWORK(2).LE.0. C -C OUTPUT.. All TYPE REAL variables are REAL(KIND=R8) +C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION C C X(*) An array dimensioned at least N, which will C contain the N components of the solution vector @@ -3455,13 +3449,12 @@ SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, C 900510 Convert XERRWV calls to XERMSG calls, change Prologue C comments to agree with WNNLS. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Removed prints and replaced DP --> REAL(KIND=R8). (THC) +C 180613 Removed prints and replaced DP --> DOUBLE PRECISION. (THC) C***END PROLOGUE DWNNLS - USE REAL_PRECISION INTEGER IWORK(*), L, L1, L2, L3, L4, L5, LIW, LW, MA, MDW, ME, * MODE, N - REAL(KIND=R8) PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) + DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) C CHARACTER*8 XERN1 C***FIRST EXECUTABLE STATEMENT DWNNLS MODE = 0 @@ -3525,7 +3518,7 @@ SUBROUTINE DWNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, C***SUBSIDIARY C***PURPOSE Subsidiary to DWNNLS C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (WNLSM-S, DWNLSM-D) +C***TYPE DOUBLE PRECISION (WNLSM-S, DWNLSM-D) C***AUTHOR Hanson, R. J., (SNLA) C Haskell, K. H., (SNLA) C***DESCRIPTION @@ -3539,7 +3532,7 @@ SUBROUTINE DWNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, C sequence from DWNNLS for purposes of variable dimensioning). C Their contents will in general be of no interest to the user. C -C Variables of type REAL are REAL(KIND=R8). +C Variables of type REAL are DOUBLE PRECISION. C C IPIVOT(*) C An array of length N. Upon completion it contains the @@ -3590,18 +3583,17 @@ SUBROUTINE DWNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, C 900604 DP version created from SP version. (RWC) C 900911 Restriction on value of ALAMDA included. (WRB) C***END PROLOGUE DWNLSM - USE REAL_PRECISION INTEGER IPIVOT(*), ITYPE(*), L, MA, MDW, MME, MODE, N - REAL(KIND=R8) D(*), H(*), PRGOPT(*), RNORM, SCALE(*), TEMP(*), + DOUBLE PRECISION D(*), H(*), PRGOPT(*), RNORM, SCALE(*), TEMP(*), * W(MDW,*), WD(*), X(*), Z(*) C EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, SLATEC_DROTM, * SLATEC_DROTMG, DSCAL, DSWAP, DWNLIT, IDAMAX, XERMSG - REAL(KIND=R8) D1MACH, DASUM, DNRM2 + DOUBLE PRECISION D1MACH, DASUM, DNRM2 INTEGER IDAMAX C - REAL(KIND=R8) ALAMDA, ALPHA, ALSQ, AMAX, BLOWUP, BNORM, + DOUBLE PRECISION ALAMDA, ALPHA, ALSQ, AMAX, BLOWUP, BNORM, * DOPE(3), DRELPR, EANORM, FAC, SM, SPARAM(5), T, TAU, WMAX, Z2, * ZZ INTEGER I, IDOPE(3), IMAX, ISOL, ITEMP, ITER, ITMAX, IWMAX, J, @@ -4177,7 +4169,7 @@ SUBROUTINE SLATEC_DROTM (N, DX, INCX, DY, INCY, DPARAM) C***PURPOSE Apply a modified Givens transformation. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1A8 -C***TYPE REAL(KIND=R8) (SROTM-S, DROTM-D) +C***TYPE DOUBLE PRECISION (SROTM-S, DROTM-D) C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) @@ -4231,9 +4223,8 @@ SUBROUTINE SLATEC_DROTM (N, DX, INCX, DY, INCY, DPARAM) C 920501 Reformatted the REFERENCES section. (WRB) C 180613 Renamed SLATEC_DROTM to avoid BLAS naming conflict. (THC) C***END PROLOGUE SLATEC_DROTM - USE REAL_PRECISION - REAL(KIND=R8) DFLAG, DH12, DH22, DX, TWO, Z, DH11, DH21, + DOUBLE PRECISION DFLAG, DH12, DH22, DX, TWO, Z, DH11, DH21, 1 DPARAM, DY, W, ZERO DIMENSION DX(*), DY(*), DPARAM(5) SAVE ZERO, TWO @@ -4346,7 +4337,7 @@ SUBROUTINE SLATEC_DROTMG (DD1, DD2, DX1, DY1, DPARAM) C***PURPOSE Construct a modified Givens transformation. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1B10 -C***TYPE REAL(KIND=R8) (SROTMG-S, DROTMG-D) +C***TYPE DOUBLE PRECISION (SROTMG-S, DROTMG-D) C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) @@ -4400,9 +4391,8 @@ SUBROUTINE SLATEC_DROTMG (DD1, DD2, DX1, DY1, DPARAM) C 920501 Reformatted the REFERENCES section. (WRB) C 180613 Renamed SLATEC_DROTMG to avoid BLAS naming conflict. (THC) C***END PROLOGUE SLATEC_DROTMG - USE REAL_PRECISION - REAL(KIND=R8) GAM, ONE, RGAMSQ, DD1, DD2, DH11, DH12, DH21, + DOUBLE PRECISION GAM, ONE, RGAMSQ, DD1, DD2, DH11, DH12, DH21, 1 DH22, DPARAM, DP1, DP2, DQ1, DQ2, DU, DY1, ZERO, 2 GAMSQ, DFLAG, DTEMP, DX1, TWO DIMENSION DPARAM(5) @@ -4579,7 +4569,7 @@ SUBROUTINE DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, C***SUBSIDIARY C***PURPOSE Subsidiary to DWNNLS C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (WNLIT-S, DWNLIT-D) +C***TYPE DOUBLE PRECISION (WNLIT-S, DWNLIT-D) C***AUTHOR Hanson, R. J., (SNLA) C Haskell, K. H., (SNLA) C***DESCRIPTION @@ -4605,10 +4595,9 @@ SUBROUTINE DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, C 900328 Added TYPE section. (WRB) C 900604 DP version created from SP version. . (RWC) C***END PROLOGUE DWNLIT - USE REAL_PRECISION INTEGER IDOPE(*), IPIVOT(*), ITYPE(*), L, M, MDW, N - REAL(KIND=R8) DOPE(*), H(*), RNORM, SCALE(*), W(MDW,*) + DOUBLE PRECISION DOPE(*), H(*), RNORM, SCALE(*), W(MDW,*) LOGICAL DONE C EXTERNAL DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, @@ -4616,7 +4605,7 @@ SUBROUTINE DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, INTEGER IDAMAX LOGICAL DWNLT2 C - REAL(KIND=R8) ALSQ, AMAX, EANORM, FACTOR, HBAR, RN, SPARAM(5), + DOUBLE PRECISION ALSQ, AMAX, EANORM, FACTOR, HBAR, RN, SPARAM(5), * T, TAU INTEGER I, I1, IMAX, IR, J, J1, JJ, JP, KRANK, L1, LB, LEND, ME, * MEND, NIV, NSOLN @@ -4869,7 +4858,7 @@ SUBROUTINE DWNLT1 (I, LEND, MEND, IR, MDW, RECALC, IMAX, HBAR, H, C***SUBSIDIARY C***PURPOSE Subsidiary to WNLIT C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (WNLT1-S, DWNLT1-D) +C***TYPE DOUBLE PRECISION (WNLT1-S, DWNLT1-D) C***AUTHOR Hanson, R. J., (SNLA) C Haskell, K. H., (SNLA) C***DESCRIPTION @@ -4885,10 +4874,9 @@ SUBROUTINE DWNLT1 (I, LEND, MEND, IR, MDW, RECALC, IMAX, HBAR, H, C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) C 900604 DP version created from SP version. (RWC) C***END PROLOGUE DWNLT1 - USE REAL_PRECISION INTEGER I, IMAX, IR, LEND, MDW, MEND - REAL(KIND=R8) H(*), HBAR, SCALE(*), W(MDW,*) + DOUBLE PRECISION H(*), HBAR, SCALE(*), W(MDW,*) LOGICAL RECALC C EXTERNAL IDAMAX @@ -4934,7 +4922,7 @@ LOGICAL FUNCTION DWNLT2 (ME, MEND, IR, FACTOR, TAU, SCALE, WIC) C***SUBSIDIARY C***PURPOSE Subsidiary to WNLIT C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (WNLT2-S, DWNLT2-D) +C***TYPE DOUBLE PRECISION (WNLT2-S, DWNLT2-D) C***AUTHOR Hanson, R. J., (SNLA) C Haskell, K. H., (SNLA) C***DESCRIPTION @@ -4964,12 +4952,11 @@ LOGICAL FUNCTION DWNLT2 (ME, MEND, IR, FACTOR, TAU, SCALE, WIC) C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) C 900604 DP version created from SP version. (RWC) C***END PROLOGUE DWNLT2 - USE REAL_PRECISION - REAL(KIND=R8) FACTOR, SCALE(*), TAU, WIC(*) + DOUBLE PRECISION FACTOR, SCALE(*), TAU, WIC(*) INTEGER IR, ME, MEND C - REAL(KIND=R8) RN, SN, T + DOUBLE PRECISION RN, SN, T INTEGER J C C***FIRST EXECUTABLE STATEMENT DWNLT2 @@ -4995,7 +4982,7 @@ SUBROUTINE DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) C***SUBSIDIARY C***PURPOSE Subsidiary to WNLIT C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (WNLT3-S, DWNLT3-D) +C***TYPE DOUBLE PRECISION (WNLT3-S, DWNLT3-D) C***AUTHOR Hanson, R. J., (SNLA) C Haskell, K. H., (SNLA) C***DESCRIPTION @@ -5011,14 +4998,13 @@ SUBROUTINE DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) C 900604 DP version created from SP version. (RWC) C***END PROLOGUE DWNLT3 - USE REAL_PRECISION INTEGER I, IMAX, IPIVOT(*), M, MDW - REAL(KIND=R8) H(*), W(MDW,*) + DOUBLE PRECISION H(*), W(MDW,*) C EXTERNAL DSWAP C - REAL(KIND=R8) T + DOUBLE PRECISION T INTEGER ITEMP C C***FIRST EXECUTABLE STATEMENT DWNLT3 diff --git a/extras/c_binding/test_install b/extras/c_binding/test_install new file mode 100755 index 0000000000000000000000000000000000000000..8fad419538f6119898562644b5e16b8fe210af13 GIT binary patch literal 276896 zcmeFa3t(MUl{bEGA2diX0gFZ~HY#9>AOVXe3gfNq)l;~2E{{TdV1uO)w3Jv8!+jG?h=#Fx)wsZ0VF0<$f>K=fOR7#%yJ8v zRLej3)yiMr{hzxCQ6ysBa5-sjQqv;^ZqqBZ9_xn75jQQB3T?}he7DbbLV!X>11HhJ za_y#EyD4YgT7xg^T70rP{@Y{H3*A*n! zU!Q<45@8&FcW?ONmFg?~_ZC!ibcv*|Ag)yW&NBHwRwn) z-&f1D`|C3G|Ex^@C(6XXvrPP_%hbQUO#F8Mc&Yxr2Jy9pokF<1Og%p;6MqDVqE!87 zm8pMWnR-Z2rRqtSiQiGCp0AaOUtXr33(MsHaGCs%m5Ki;`dbSAe=C!}qfEPQnR=?r z)H6~het(&I?k|&nWf^!rQzrhdGW9%+_}8NCq96Ft<(FNxxoz_$o5+REh^$+8`IT2~ zT6cBZC7avUt&6N%eZiV_mu}d+;qoi4ZriZ=f;B5QUbSh%1($qq;|5JDonq@mJ)5uC zbosiC8#b+j@5;zJKV|(@o7P{_W-^50uh@ikHeIrD-Ih(Qm#qJADCO$5t6Gcm6ZESu z+pu{Z3tkTQqnod218{yrSGQ@@x=R6hDE_Le*KOFm`KryKD8H`tEthP*WIX^Ws%`U@ zO>I|Pxj~DryQD2t+BOu5@;f740kW?omfsxNxcRCrn=UoZWs!|nU4B`l^{S6XI2>19 z*~(0(Mc(z-Ym)0WUWHC?Kwb%5(stFASFG33(U|qqej8+{-FodNV}t@wkNY~FmuhRwvpdc{@imbR-wmZ)X@hu5ud`S7~SF1cc3 zq!o14c3I@g4Od>hp^eV^D_g~B{a6GPacSgAG<4N^6kOka$-2v~07YH#@eRyz=lQz?pK-crzL$+ zji;<+)0ksC6kn-DX9enNU1X;{QfM@mixMjfUc_XwHOs);Zhu8bMQ2fh6 z_0)&rDRbLjLn!{`HWF?u6#t4)yc3GA3B@Nv@kX_h)TU7Uv7!9Uq4-yY;#)%TR)=JA zYbgG>Q2zE%{HsIpouT-pq4@4ld~GPcClvphP<&q~{3#=+(bsgA7q%Ow~0Xszn5W}+$Q=Zd>+Fz zwN3O$_-ux0Vw>oc@H-f$`D>z8!f$1mCdY|p37^g|O>7fM37^C;O=}Y|3BQ(Mn$#xh zC44NyG)+#_O897oXOcUC~poD+QFimF@{Sv;1VVXWCdL(=Y!!)5ybV_&^!!(^uv`Y9E zhG{aJXqND|7^bOgA}Qg2XP73kiI{}{g<+b;Ch8^pPYlx}Hc>0#&ofL@*hIC2|CV8z zz$PLR{v^XReN9aMiT(dL!?g^LOL#NGG<8jkO87$z)5JBAk?;o@rfF+pP{QwJm?o`> ze!u)>JqXK>^my8DSG#wAz;PdTx*nNKUXVyHeDe=Ln&~6IcPE{*b|UA2V_u7T{?LP9 zBL>JxFC-l}jZ{N3A~om2Cj z=w9dUr`r~zg8QD*3MvkaUsknrRZyPrb)NNo)F0XMhP6)DS>Hm=h~xfOTczWjbu$9F zWx!JIQvBJwa69rvFGkyb`z$~4Q6$o{7Ufo4wBo`QYgb%wzVnGkhcS&Vb-V>9&?4u! z@sZOqjyvwSsd0=%HuVSmJsm08)D(Q2GTGEq@R8WFDN-w^o!85Jp5&>zanxDA%jwER zQArarFy!vM71<)<-TOW3O)vgFy~CtzDG(jKmHt~8>pcE@=fk7bjyvj{5Sc_Z?k}BX zyB&ATY24FxG$7}Ggwyqz<|ufv#MI6CHQDD$q?hnMKad z+SVBGR>1Tr*D7NQ44l;Ng$fv>0ONyd+qnV zUg9Ufg&;GBr~oUDVr8|vXT=V-hm_Us-W4xEyfh15mRr1>nd^K?@G`Q$s(Rsa%#i(6 z?-75!_?vbDUo7LLSjNW}1He}pF~ApNul%zXTXm^^X7bsfuZyr1@B4MxUw_9l#P}K~*xh(#fbN(@zoQ zxVr;HwIiP*YEW@99Kwm4>etADP-J>>ig1Oe-*-dP?~eu3?;&T|PRAX2wx%DZUTz+y z-#jp#PNfaMGx2WiNsj{E7XsQ%b!udHD6&LPz7y)nW6xhtdP)qG<%aP-?NzIGpgq(9 zH`T0>EuqK~gj_H_8L-D)&LLcZvd+6pI?g7;W9bvzQn-C($=8$qOW<5a&JH|)3FSSa0KM!y>j%)T2`<_@MSWrt|f z8>DZ|*;H*o-xx0HTM#LI`^qj$Q@1~6`?d_Ca+lQR_l>34w?m@(GtabCzoY;{hKnE! zA_c;a_z=F{hw#&opu1Ac=tIcBL1BLys=wu(0x+n)rT}1uivSKH1>kBQ;A5|%ffLZFG00y~KpbW|T;AcP@XQ{z?lG)Vaf-W&!)TJO&y41VVQps2T+jeQbbcq@L zE-^6sE*(mD%Fcq}OYAJDw*7mjGEs(u{+(19Dg9gM_iy*_O#k+s*p*^YzjF*+`*pBk z2bpt65D#P|j{88ueZ=u@$jKsb!?-vXk6h}!X^AL^Z3}a+o&*T#4P)d{?zn@uJuzKL*kbH)y zZu$7JE%c#eq_0)7BTMqN77T2#Cn?Q|Cu9cQj=DhEf3 zLWK!%1}P%m85CFzArSwkMzzeCEt6i*%d)pnHi5;&sage~vbh@`Mb&Pqog^M6iBzk` z&%S)zb6o9Z5C9|UE2P&Fx3biysI zc7Ft@0;Gs(Aps)*ph_0xRj39Ps^J-+`qVx_kAphaxW8Wg_>X-g8M;Wt6e2qL5Z#{- zQ3En0g!V)n4Chsd`W2#q0HTru_J`jHMD?aR!IRL3#ghe$G7&(a<2Po=HV;)?n3ZH@ z!S?f3SxV|r!1@BfN)F)r6tEgood708XaRF&;Q&ZVJ+7E;65hol32$xYd!)-ms%_uc1oWuyDHBVNe_)P;03KaA!F{pK%1hADPfo1cU?XnxO{^nyht z+pP<=OJXT(_p7LuQwcJD3!Q9g5G82bhPNMHP6>Di0xx5kVQ=c|@Xgzs`Uaf&$diF9 zv)E0Iz>An+8v{d)^}4;|@Fv`Ej53cAkbLDW7_2NB|?CIL&r-7%#g>9p$Q ztU)!cC<}3!7;1*sfYcIr8OscNQybv}NLRv%B6}xYmUL6y@FJ$&#$;1{*6a56!<%r2 zdYA_!q97$TB-0CKRSj`MVHjoFWW_#akd;BYfovr3GFFjwCwzeH2XKh2akvJu9K47b zvoUJ-HOPtxEZZlU#}fe%eHqk{%r7@JEFnnNz!cDDF$J&1RN!qk8GtGHqQDd#ljNydn$QG?zeGAs6eZF!cu-?GrJQtc53{9*DkZdoGTnzF`Tsd-sVfPW zT}kE^;ocji%Y?U`^CY43*xr6DU_`0BnV`b32;j96;kq zIHuKKbX=rd2h+ZC5t0J{2d+d@L93sx2PI4GRoJ zrsH*Jtp=@Dqeu;^BC~zM@zzumr;owFAKf=54fi|V)=nvgy_$}tPP!E&;c(`(3!vX} zytOs%^1qcL5A>i}R!5QKlaIi)b1<8`T7$|Zvbjq&$RTCswHjod489XVY!yu_D34)& zKu~UAFWsSfaeC{-N!PN!ZmLF{bTuQfsKA+CP|m@`Opt?&vk{cXwN$A3GJ^7$W+ZS2 zAt;YZsd%j^Qbt5>C<1*pB658g^ch6tx+3VyiO3P+8zwY3!nj04t}WG6zLf0C`!z*P zbsBj;Bq575KFOTmvv9O23jWoF#jRXS@(KhasUV{jjMxf1i|CS)v#&2y6gANzq)V-; zK!BEJ2DO=C+l*>hMU}{O&_zCg(+Y6?TE~E`ql_x>Pvby|**y$;Lxu>_rW3AtwM$Vr zAb45D6R=UD8=R`)yei-JC=`7G6eY#T#R^3Xb+9@SBL&w1NDT@S9lseL!GbXGK!2{7 z#as|f9_bhH1>8=Bta}E?KK={A5BaDg!ytGKvj-8NftK2WW{i3gfK-DFMm?do7^GGO zseJ~Je*K_;RBfsgWXUATgQ^0_fQpXalCKGb5EWrQ(eGuC+0W}Es#&3GnE|SE6{;yL z?5s|pnq*N6l~qwDnZrxb2{*PH^Eqz>DIXc#iQaHtrLCj_))W9%Qg<5uIUy3si`5BW zJ*5DnBnA-Zgd0=kH-xcK0Zf!%dc%1Yu$Tho1b~$!`lSjO#YXDV0+>*x#h9DggEWAo zGtN!j#;m1uryN@p!QC4^25@>ZNQdE(Y_RNcn> z=7&bLd8%#zh%yF=pltJ8b8Yh^oucN^-T-v9eqShjAKGgO+N%%RLwBJ(rZa`@L3**O zV!X~aMphFv2I&QQBBU2HnR_`wu~PH{JR|7$z$=ReG>E{23dnLMBvjgK z6q;rfFv(|9Xh^4YFQ+ML%OKL=Y!F@p&T!ymtm5o8_yE}sIKAnV8uqY_)D z)hTq;GFj#B`Fb$b?n&f9<2g8{)n8B#=7L2%m~+^)TE`(!zFwQ(>fO|XEngQV;4P*? zS&g2$iw8vmh8_&IPCa-`T1=0^@ilMg!PLBAUfjXC2|bwlevP(B&AVD+Lz*{M5?}Kk zK~?PMq~pa!51tYY7%K_vj#x=#lfR@Y+yrEM%kx!XfXE2|Rh<*SSJl^93RT6N1ZfNe z6$&QQ^&JrdW=VCO6iqOxuGff%F5}c2N8mPJ|IrIpJ@Oa&h+|u zw`OErCgW`M^Uk8`%joCrnvuXAgnmx8?L%*M=rUTmOmwiQpoQ6J>EomfiyzxUnT;%& z)OjtG)6#ngcS!URU5JbTO@#o=SJ8D3tXYe;z!5&4SD;`cOVr<_7HBF}ptN#smEM?^ zbZp5oO79JK18&#q>;WZ-E{+bhfN;ZNz3L_bA<61(bQ3P*;k>E>)GHtj0U#w+fF%kD zCrY53u&5nB?sJ+&yM#8*{jUJ|MjMy?FQ+6_wF*_;3{ZV)RM5lO?C*btnjxb?!*q%} zUad{k%+SQ^v28gw zPV}&57PW(50Tbq@Lb~6WuTqBqt6;BGrKZ=<>#Nk0oHrpmRC+;4>UjEx0$9XUCx9ix zfVnD`dnqMNH}xZM>yip$H;d`+Rwul&y4v+N-6Jt&*7IQ`+Vz}tS|mmIH0YXDw#4RI zd(eDqUi0NQ*9JoEk`fEs#pYVP7J$iFI|>vCQ@fM!xP}|Nh?{yq{jsW>BULwNy2hif zoa;q)ClvLlbNTJ>EB8D1` z#DIxfFLt2d&{w572Nd>;-K8i>KSq5GM8I=;_WvoJWCwzeH2XF}4 zI9vl66&J)%qcM<8S+Cnmffb7BB=h)^`yfIP=Z7^?C#u~Pt49H&%GAPZ;HV3{j8(nw zWcUEmDR8LD#ONYFI_toTm}^IYw5ufZ*qsB}xI{=MENu9irZcryCZehY z23eg*H;{D)UdAf2J_8>hOT!_u`r#VL2H-_ZpN+u=to6FR878{h2kCfXN8|FMA(^qz zXf@Q%Va%o`F}4O-MVpBMA56Cb_>fsF ze=|`To;Ih9Fuyr&CUW+ftvz3*F`J1{X@)o{LYs*sbhDXgltpSMlo8S5qLSJPmo}@Nl-f+(!Rb;`iE2ecp%R7G zNaue3*M;^U>rG4hu>&c3&>gyMNexIB*lh0UEGW`4mTd07HOP|GV#YPdp<(cD4U#Yz z+@(Q+#o$c{_RO#)*^V>V*peKkFyIaiiqktFPFgfQ9MvH5+;k5ky%cj!uky5LM%Hx@ zDo=A!^<`9^Ce29T4npNgN-4Wj7B8dh^gStk41qoyWv53=DQ0F+cDglh2>No$PA4IT z;RuefNKtk=OEs0R@AzAi?L|#>mf4bQ)u!70rnn{9T3Eca)+5SNOe=6~1;LJ)(4wvh zz6k2?n6(r&L8fV>R(ky+s>Ic6GYz&GK}mB_CC#j)a7$9)tknwYYz1mwQ!-L}rOH1+ zyH=^I){-^0WErJybT{EQ%95ovJ!hoHjlwnSPG&%CdNf0KGC9M;c~zr}C=?X|6eVT$ zvlR;RA%7=RhA0>pVJNz2`px*`B6!Zj4f(to7kd37fi}TWfEWNrsI`nXF}O?cQ_JdP z^khWBTtyFKC<6>PqdS=)WK~P=MA4)-oL7-Gt{~-R0O>ddslrqj-T~7YE$VNC5G$AV zTk_SeevF49B9SCi?V{Ju>mzDZp&FY3s!#6}L{ZZ4cQRW!`gy~WV=|1fC0oj9OCvM1 zbey(C*#=cUjvTVF66GN$D*HtX}~e2mmWNqo%$mfDM}Jgh(P`z}(bVkp`?Ng}SM0 znYGk5X$y;~HMtpHXu+Xv(oTsfqXiEj(Q3gY*FtTSM@+TvdTX-eHffXJ{7_Px4{ei@ z!b0+3zA3*i)I903sQHrHqf($>BQnN*i^5V^*sK3`-EiCbM@f$wWOWp#;MoHEvEfg_@$3ZU)yo^<) zg?nUB-?&FcrG+xKQCdXu4(*X)b@vl{d*Fqx+X)Bb$nnKYh-rvqL8V7S%8PoZ2q!ia z5osVBgx5eu{lIt`tB~CWA0XQShmeiJHIR+LiTyc>{ciBIHO-ugEHXM1YX9fez^obKz1A)>X-F&ksmcv!$SisGuYs&R@G@3$b}f8>Y%3h%tOu@v ztPftqblVs`Lv3(2h*+2j`k4nzK_P3_P(&eX(U1u5Fo_`2AZrv}1JYRFWvn9W0r;R5 z|C|m0n53)7nt~TGIU8g4T5)PZ6Gq_h2ap_bdSi6dAY%|R3b1VJftRt0kO$xcLVga1 z2$_UyTZfme+Zb%>qu&N0)$qb<6CoyyDF9%x1PnWb&YUSXioDlbr;x=^z(7_HuYs%~ z@G@2*I}<)Yb`~5$mV|2{Yl0Usj*Y<_v|hKjm5FFpfoRrHEn9cxTshKeHLXt5a&)k9 z4VpKQRl{o_s|mb}RmhgWhY>pt4k4>&P)Do*Uc}Vd7`ykCifBRw9R6U(hyYozW5~oy zr#lHmx;Msb=^?H*uw%#?lunVG(IzoqT=GDMSts3Y6Yeu^t#LUVOeeL_CA}tdzgp?r zG-?QmCp__c>_Et-!TsS*lrwv#MXOwyHBHwsV`M<_fX@f}!{m2pbqY}CwTfj0XM2WP zgI0sZEuECuGObRcD!Y>EvX*b!;QsI!^1zZZ8nl|XKU^KO+U+lK=}uYV{8sb#heuGA z?hp5%aPj_dMp{e{!|{zNq5a{Av?%+-?b;%ZDOA()j49#$;XzczewN)ICiC%46-z^= ziX;*WO&hTH)XPw$IX8Xl%Q`!GWPf-E=Ze|JZc#8{fk`(jn9-6J7)~~VS$cmM78TAo zAIz{tW!!X-78QrI6SAnV^E88e{bsm!b;#znYmg6`W)($m>zT7PB=gjA|K*Us9%wS>anqo`Jb9Ptqy$Y2BsQkU+ zJi2(^?@Eq*Q}870(w_Gf`mlJi8a6p822dEPP(UhUZ$XFYM~{T6U4hKVpG3Z0p+_mH zFQBB7itMQh7#DKit{_Bc0h_xk$pM+WE2;1K%-xlQTwp|X3L)U{lnW&W)=uliPPI&^ z7x`UDKByBuI;wss0!geSR0t?iC373^5`~}{(lOT`$jU8n@&)t~(i@hSpj@w| zXld{wGYHCcnzuG+p`4%`K^AaB+9yPA3Ge3QHCdlW?Z%++drPu7iEX1_gI(@rK4tfBsNQ@j83cw=&@LPbf&*9T<2 zS*Wa{A_kJ@@y6t*zAEUVna1A=?9sWD$6m~ygE&5g`6_UTJ&a0C&-}*ZZ@(gd(U|9} zz@1^h=59>xgZ*^w#v~U=vyrElo3I4YhHv%^Chf|phbLuW(leR5XYdr#v77NHINUR! zmBlC`G)^I=!p4Ml$L4NK5@&NaCjE^ka48^U?#AReXX7+CCW}>H?tcM$RC^=FjiC~T z`!Vy9xeXa#4X)*)K6h_&?%pKDT-_MGqhlSozeu>x!@bFoFUn$LH?_W_L6z#VxqsIn zMNjJCU(}!o#|VB#gOuW#x>bWsCb$W~nY8q|dy~H8>8rQ7|CJFL1j{%GU42|jjYz2( zboH^K7Ru@BJ!F1=DfcF?>?55X%)Lpz8=CRQ!Q7h^MS!ZfKXm?93hgUE7u5`r%F3K& zedHem5Ka_d5fDt&Idz0^0s5qPby|91?^$w1nzbWo`wRXH_hK}$1f^=MTb=y~~ zCJIw2*v}Gej3-7zaL9_OkCM_`3`;~|@$E}x3?b_jmKqrZ^RP}cixvVV%cSEE3wq+?JG>> zRtRiH?c$jxqieMUUdF20^^ERNexnEVpmpLJJc`>U2yuvLtkY1EX>)fdacncGL&doZ z^i*p|Chy!GO2x@2DF<7QaQFi)HPCtC-l3E)L&(##)RUh1eah%fzK+Ei4IQf)PN}U% z<%560_bI7dadOPvr}W=*r3Av|ZMyrE|KDe2-YApF=KhZcMRtL*)1$!{XBC2<(4eyK zY;Lm#TTSYE1ZPr(=I&F5H!S7yhrJU+aX3DklYP7=0#?U;v>7)nyfA0H~Pr3pH*Is|0GbY-%zx65%1zYpT;_EX0K4-mZ>it5{ zq7|y`MfN%A^^5pA=p^UB%=amq6*8(&FO>U~Kj;=@RS2@oKBvq*JEH{wq8B}n_bK0^ zP)$_z}H$dEONx_8Q!P-!KbDFVv4g}w%Rezj)Ak$2@knG?Gz#pDlyN-eaaOI zi|$n#?YLTdoyT4EyPD7AeaeAP36ch-pXS-wNEk3&DN|h0f@<&a{Tc65b`#RVPj>Lx z*(O4*_ZyS&n){7#V! z->1|IlX>?kzofb3K4qu)=k8P5{oA?wl-QA+yH9BiPILDuW!3$2-=`#l5AIXSt?~2@ zS%cK3K`us{200sDGCjKFhjeMLrb}K)mpqhit#LE3{xO^Z*QZO1V>0)efAQ@b)KFpH zsD@K$-`9DrRPZ&|fS4MWZ1=+~9pdlPspfDv9-WPT)Kc4SAK z@W&@bC&niwM^}7DHVAf(&zHUY&^HSo`x^om&j2vC0_knxrlfpnnGfHw#mlPxI|D(E zL0XZ5;7wEb?yKY7IteG?b>$?~H4ewaYmq16Q*_=K0{$)63t80hwv93)zW)xh-^ z0(^bRaqq?zi`&u4w#z)t54ORWp^TN}Y(q7eEMmp{Yqb*?2z>ayagq0etryp8!t+av37@_73D?r<|P+&3B@A z;N$151XA({o{(pk6P<+VqFoYnyBcKucOO4+V6_W|E_CRmk9qo>`H_VCE0X+0ADS1r z%&EFA0}{jIXHsT$d5~HnjD%8trK@%M5g!e@{W`r{xR{#Sf2qn$sFAoLRq)$Fd zCr;y&9dA=gy#qw^(h#LCcu3>_b4~ivBSHV9Q%lB2A(0;t%Lo;G-coD^t$9MRgBTYO z;IM$TZIDoSH%SN-tMiVKEAb9Ua#uf`5b=g$i->o1KJoUUB&y3J-o;OYV(}GI61gE@ z_TVPXYYF&UhJYQ6kk?fMiUo;Y|850nR^)s(^6KEFlTkBkS9$gBw#7pJ{JW}gvg-d> z^8dMzzszNj9@|ABPKJbc>lEwS#(Cqce-dmmMyRAB4U_RE(#^0s%`i{0@jjUum?0Pl z5buToeo<&=?(Ocb)#+8o<4qEsajARS^u@(})lLa!`qgX5Om$}9X<9VT>cApNXn=c+ z4nFEcK=I-ud$T%9EEl8`aDE9FZA} z_)5%XnZM*hWR>8cU_V0;Ib>G*Q}ujjKKQ{8IaR-YS@Be5e2jh4m4GCOf1x?a^+96H z0%4Yr2qtZOSZ1w>i4W_n<@n01rDvj&v$k+5Xa5v#aA9t>zZ#jk7XI8s?Thwc&SUKY znE$wi4B!)cxMEK8Vdt8|Faqw58i=g+8)a^<+=_A2wASD~{3+Ne@i?S0S4Pl79YpP zSs9aWI>`Dr|XBS~h8HTr>cineE$h`5=sj z%f(_SI2?{iCWC@b9_%BMP2VN5a@5_RU5F<7Y7oI^U!*?mwVu`Bha+73eQJCghX&)q z?ub%j)7YJMg-SC^cTBnb?(~GSNq0KKG147VFuyw_aR4j1F%%MXF=zD?sJ1VXZ2Qv3 zn%xlqH^?sFNn<#Mh=i;PJJkwJ3pHvQJJk}7kWQI$`JLi90#P1Z7ZKv89kWLjoFozFy6b)08z`+D|$MHk#i)7F5NX*Y5y-4~&c0uyz z!>@vGO7a1I2@3quu7zKcE&SYQR``2#Q2OkkbZxDTR9%0waO!w1A?Bj?uYMR)8Q)}L zA(BuMaGmYI7qkO)39r3wP3pjw!&ZnAjz%Sm z8}C!E0F9^upnEh`fF4(%kx9mbne&0}Hb8gFW|9GT#0R)l0d5Zfjz!wq(LhXrZQDqH z!fOSfe*~c4HQ1G8`$z~g3#@SSVKt&8zeR7nzjq%08IV0H5Tu&5`4-!}K7=l)(|5v* zw;L;u@$#(=@#^bUs$J>JZ8))l#PDW^j!IHnX|k=9Ib+$miNh#Q!(fER!75DUQ$qCm zVO*>-8ln?4C09RfN>FlA^7fhp2|-v7irJf(F@?~X0m28b6bMHH2+Y+!U6?~4S8I$o z{%6Z_#UL{(zq7pQ0~y66NT?*p^$K#s3?RQjK_1g~q*mDvlY2#ZSgzMBbczvFtF6@q zt(AP!bH_$O&!$#ZeARr?{PJZKoz^r{v2fYqgy^1zGV<`2eR5%02(0q!`iq zD`u$we?Bbzs14UIl~-#Fonqi8pO9`(!I5s4q4PeiyrQUb3b!BzI>nWbYvs8aDu0_+ zJ}ClEcoNlX<#d9|Ic@NN@2FNjW-Bit!9V;VL5Vr)o{#c6t(#79-5ITWB&d5{p{eCl zT6e8hqjje;9V>APst%JGZ;`b~(hiD!zFNAJutV~9(v?t2dux%FUGTRr0qRAje_-OR zZ-v*;cr`p3VGNDCu05oRj|eJ$s8K5Jm--GB(8{2`&q;mqu`qN*#Kf$;?y9zoR1Zc| zC<^EL121F6sFC^-eAs8%4hNr8l!36D31!*Z0yU2X4}cJ!+L?n@0oVyO{4(jsOITA2#lFL0bdUI{Pz zML4m9HzQ8E-%d`20ZREKfWAS;Ym#W9Se6Z7b7d48gg&W892EK%~RF)Ap_PdeGob4w>! z+-HH7)yvDE<){}OTAnphIpa-baB_4QCov@zQ5T=d(j!{tG^CPzp^(a}PcMU(m%ZrF z@~n}{OHM0;lf@yN*w^w7lAYj1WQr$bCluoH*hz0#Jb8xV$E;cCarI?7drZ(-+CSP} z1`WK{XyeAjy->{0?yjzfqYh0Bl1FR@sf;y)YaV?4?X*$-3LKISN$z~Ph3A2ZD^3N> zYLs~kICTJ6)%CBJ@Y(^y^#i%FKq#n(7ga`4cDypP4GJ2 z_8fI4ce}$79@F;IQ>~Jo8k6)?v!>U=G0oM%%O8$fFcu$#?E!e*sH7jkLy=jEI164G zA7Itt)h9J7jitsFu8gL4!ZC1l!>e!^q4sRp-p+$%>Tbuyo5H)Ix+k2v2S=yxcJH2E z=xy9Nqg3~;Q-J+alI|-wELht1LDKby?%BYN&M1HA%A&{&-7HW<^VYK?<9_wzGT5jI zW8>MR6v4)`Ln$+&Vb=U-`y0xj;gumYYyld!cKaKwaq3s3YI$W~`v|-^gF0V#O&cHU zfJV#@OlPq}21Xn2lM@N=z%CcISMibP2V|@DW^79>yzNxkJ4)5k+SIkRKGJp~3gA0s z{G4TVn$dQ9*~T7aGdq#C^N<-V(T(5Mwe_}0$Jx`WdIYP4qJFIH=K~X;J1G*$#&1jR z=5*NF5NUfK>bGC~h-cUh?we(<0TCX&Mc`FILv?6~-T(d@rTf?*>)INFh4@r(JTw`z z7UHE6w%e5lIU~(dM`k(*PNU3JZn)qcq?wA-aU+^?r&Y0MO=FGA%Fx&nixM!Np;quh z-HmIU?0`jo7f1*aL=AY(Wt@DxYiBLK zfI#nRcR%*z9rv!>LqC(P)^r52B?ec>REYPGmfKfbKp&WR^7S|bfyNKOf=ijj>!mfy zN-$AcJ8BuR^Wk|;bQDk5k4y3p9h~kP6`4A%A^F@2cDB`I**htnd9;G31EpgNE9OTc z$@3EKJ-LlXW9zwV4`dGc+=tG|lQRa0(9;fBN6~~JQ)6{O|0*IugEzpLAG+Uwts9v8 z){i);+uL62NWajv4(A`8$DhFdO^1wk^8#3lOsRtqRg?)M>Y} zaG`auPQb z`Ga==UgFK&{uGAIlkb5Zs;CB?LW%r=iSM2O?;$X&I=>3^wVx1Satwmeo2fA=K=SX~ zBsw?`GX5HNnkneC*DF%CtP@JLKDl}edbo?X9odnMJF>8^_W0G3LcASf8uIsccVd-M zqb(n|J%y%ptTH%R5p~j=IU%^!3_4waqOyO(lNFP)+WgS44f&`~Xm)~`AD)fh$wAn+ z2p$=-_(<1eRIG^P8Xk|($mkwEDkGv(1^fEBSH9<9`kMM?Esj)d#so88F-5=IG3*9g z(&1Kw0emN&svGk=yv#|T4GJ`!UQQiG;H&J0uLULC%0cPuJqUBU`$yMOe-OO#@2bXJ zFjoI1r(Sl9AwJ>VFe=V=hQM~YGh-nGQ?Ve?OQ2!xuJ)u}Zg{L`w7|}xPA?{Ggb0J| zte>2&8leX%DL%i@s8$X#01F!wkn}u4)s1^W28)2g{8*d=I+IrCoI#zFUak^JqVb^) zMn`fOrv#n&`?=giq7+fpQO?WQ2ns5M6GGvFfNcBYAAEaR6`x zJgSaty$I5N#FE93@xTioy?ud~vC6w?dGqB5AJRd_Dx|~kl55$R86fRs_EL~`GXcaU z&QPs5vVJAf3om*d79boNNFTEXzFhpod0;H0VK5fdg#kQr;|Ua?cn;32Q5YznDqYDu zu>j-M!Imm-XDn}{B zY(B1J;)2n4rxzTx?`1MOZe5eQ{krp4$P%&doJ8a8I2KpF#;SiXYxS#2X40Ca-l0`) zY6&@Uu&fvc3E4+jD7X=10OpZJr!*&W<#CAVD+yzR> zRwR~0;~gC*o(+6}0lpRKWEtdjTocuA*F?Ti#brW{H$X}b+A&9ut=uPNCowmL5l--A zpeZ`z3iIo^73QE<7lIG7{*Gs|#0X)bf+WUH8ModY4KFb(xKj8;WS1C-%upq8 z5Rx1@eJ;6+pGVG^>k?B0YCrNH(i&qy4b~V@RrA)E=|Pn>q!g&rtuepH;bdK7Cg96G zw6u7QsaQJm8Z(b;jM1Se7{2?h2gT0&U|bEDOK%D0=1)~hTU;SZvp6m#x5G@{we`+O zmHVJ@7iEz6L_8RQX@sKYkkk;YWnd@sjQTxgO(o{ka&HTYhLz_B0D!JJJ7NX3HX#gP z&H6$nWsX_kVE$`Vc-;$$oeac5R;$gAh~WCu5EAOS(3esivI}~^R3a1WVIh}(rY^x2 zY^bDZn`?srNnU6Z1aT&I?GLpwpr`jyf?+g_#n3hK^#yrZ05ZDj3zGNHBz`VXW;vodu{~eBhtR(S zLVr3xb|-{>l2VRThv8feTYwQ~ROmrVe^EbIo&_Zs zC=*Nj@2jpmW+ko+T~>9`9TfSiKKX9!<`JPsA{Oi|6~i*;6P8>LN;fETh|x*6M%~e9 zCW?RVf^P;H9X6*KdnIGnu6fbh-AYKrX&&hXqwWdU+?AQO*i!br9R7zC1y-w(xKI!Jn)d&io7ZZP-ICB?@yQ`g1s~>0AxUsHbl)E zQzY5o{-X+f%wxq3Ea$xcC<323Dd^(<;|i2=ccZFtMIlKsv>=w1G-y!=CackMH(NH( zYEp)vO*uM>WzP%;7cP7#SkMEb~2(W;Kk-1IT+;(I#b z{y6upPe*BLuSW~gsm9%M0aN_$gSYi7X+K4l*v&oP89oGLX99<3NH*@Vps=|jlQiAJ-Cy$8hzU=tIl{e>%5}4t0 zW^cI`?^}v|vv-lE9|MmwntnaJnBdbM?FsDOR@0v|N?3O96&SuhP-&*gHos)~&g zSHHAa^er@e7aAqLgKhW_+bX;4>CRkgK5pVpeDpCGHYTp&sjk3iedjD0zp3b!g(5}D z2Kr@HbtC($-m`|{o9xAjp!umftd3Y^Mdo^OSSsYi22ax2(;97WL6_2XDqG1n)hw*Nmc$UhZpm+t}E}1c4512;;$b86T({pUi|vE#c!+n z>|d;1^Gu4#9{yPFNS5Lsf_p<~=1<2d#L~|LWzQme5+!gFO3uV#57N}Fr+@Dkwr!6k zS6#nX!g5|@l~+-8RAg1-NU+`dkH|Zl4yh(n^>=HvZnY4uf;MY*a#uC34Q=ASQF2|} z1D%}564$t6rVZaFN#l75z6siz#;%TI2q9RD1pYJU+2X#Ouf|1VV_EDo`Ghyblap8y z{^+>-S4Z!KeITvJU!mac$Z(B_{&AVN`DQRff!_8bg(S#+3W$ZzQZ^*>TU_g7cW5EC?8HtKT<;8{i zrO;J>G#`^Vea3y_ob^XIva6h1e441mk`-F&5QBLaZpG?@Q!_j=YWz~6)^x`8S|LMP z;ci?EwOLW&rCK3Nihv251XXxbq47(F-3p`-C67 zt$~-Z5Y8fdyV~H3?(Nz_2Tuy=+izklHBYZaN98aEs(eNVA>Ur=AY_>a(N^h`k=PmA zrX4gVBY%UFkrgX$lcSOE3KIReH?6phoi98bdCn;ub;XruQHF;iq@sB05qmr`hnbcD z=DLX;BC#}rz>3{2Zu22)r_Gw}YK9kc0mReQ4lnWTbyf2?0=W9NB=gIT;Wmd}9w_UI z!MDmi9*-E!oKN(Xw))v*g+TsJv_4UZTf*!E+arxEqbJ){4TnE?YXUE0<$P7w68JzP z$H4(Jw=_aKxp^he9o;!T4~F!SXN6Qso|z5WZ7*(jsw~9--fi05G8AJHXQG%_zCkEP za{CA@Low$AkM%?uQ93QUgm4;=6(#CyiELK|yoPXU;pHIAW|W^p!nqeZG`ccCd4+^? zy}~RqlM+sby;Uz`m2mdJH*as(_u&MDlghNiu5YLa3wdJw_&!WM7G9HjB>$B4>c^i# zdmW491($u5-({wK3&lYdrw+XL2+P#10@0KDY?H|4KH%kxSFVDIOs0;Ks z_cleGA;Bkcmb_xc4xee6L_h9LD|WDOA=CN-ZVG_UNN#^9K!Q?HJoQ`4v@jXkE(Jl2 z0qgibAVK1WoN64gNFTN7S)3pCvj%8n)+r<;+^^)sxoHp%3XZ^;Jx!kcTrsn^0|pR5 z3xOg{{zjo|hr=HL?F_t(Rhs01N-(n&9MYur_c`TT+QhUhN;^@8MVZ8zSkyHq3Vld! zA1!5A)L#KReMAHiWsxAn(T^x3_Si&-4e)Xx1I3@c1X^aYMDM znJ`<9f^A*fqiR`~WJ}Df_1l`sxNuo9`j~9!+O;ewQ-Q)FVt6+1Jd;-^vFFJw@MO;5 zDMro^yttTylfVY4(>T?EZQq?(*?*Xb;<3c)h1WeHP?{@153&q^!1J7w;&?fNb+V8?(dkN4Rx*vc9+Zd%Q3D7H)6jNzpe0 zwhTafDNpl44UIv_Nd<+c53BAQ`o6J^KkSa ziHfMtJx0atNxM@UFnTwBCps9>UK7W&S=4k_b4hg~-Q@_Nx3SyW;#6$&1d#Cg#rnnHO1u_cvu9a}WUv{Ga@gZeq>`236{@Jvj@h%x+Kq zGvvJ43v4C!qXM0g(OCx)mG4n|YvuXhvE@Kmj)-O4nKOjnFqmt|MG zPm)|tI6Hl2bs~BfQYxR8yI)7*h-$^EKOFuW@s$mu2`qDU|rdyvbO3 z|Jmuqkwo;TI5m%qM^)afj}!qWP9D&lOrDwFFP^9G7wfyP`d%;IU?nslhAji~ezAG3 zHya<;=rtKc4+77eKe)fpN*-ABT=Dp8%yY$p35)}!0u&-80t*_tDTyjS6oqDf+VAH@ zF1irLiKaiyi_on_#D(Xsad(nJ(?_0$Xx`9EpLHsHxjhRJ)U9?lU*fIf4BF>g$2q9o zXuXLD_P#cZ*1c`iArkBNKd*1rPA(NJ39`a(*4{KA17@EYhPCM0g=$jZfWH+OBaX;E za3e<^r@bHNSzdwoJ`^M^lzxPECk{$TV+PmhV}AG;Q7Dhlz8*S^c`w><551j=`9BOe zr++Tp*Q~ksfy-8)6^>|wVA!h{XIq^(U#x{=*!4Xf7hoJJ5J7egR?Nv6@q@?D7xGFp zj_}<3nRREUm)C-hr%*XN{{;M#;y-G^V?ylr$>jLIv*9JmD;HGzRCtpiM%IXmHFRqZ zArRbZcZ!Vgb-%=Z-7FZJsGA>q(`>SW2cC;Iy!f3H-+{O=n<7&Cb+fJgEK~dYP&>FB ziJmwV3fndyoxN$0dHjCe+Rs?t7V&QFqc;j)SC8-OhR<6tjDuVl;!!2lF*+!M^HFxu z8v&)t3+?`5_XHMu7%oS!2EGI^$XW|xeFDT=Z=XxX^9WdRL8)dfgrEiH1K1&H#R&sl zLM36w?~Q*6Pp)srZRq$QItO~jd*|8sfcPQ&GYb3)j#^yx5r&-)>pA#%Cz@jaQLH<_ zL3xvdT*k#>fX60SG(~OMYkhRmXpWU!95@6ugByn??_g zpw2_{B&Zh1e!#P0;8y9RMJw(R0V$o#sN=qVGU2Ukcf6IY7)Ho0i>;_M!c%688z>`T z>?RY@`#JaUX2tm}lwJ0#?81f2ROk<#=$BKrezbSBtzQn0lkY|-1HM{s@0%m(tQHJR zmpYKb&jb9NPuO7k5xB(&1c;-%kpIXyFbWbH!7emtXQhCKPcJA9XnyaUW(&&{ipT>rsQ>3EY5A4gr_TkxdpZg1OFb@M%4`=d}|EA%@L`wkO)jKrb0 z`nOI6!)hnYpwqZor6emAUgP0Lsw8kTf*k8cGKT#M>v8he_8d zjDa`e^ew)qf*rl1@y1RkXuTU1d6nOED?h2cF_f7Z(xCLJ8}CAa!#!m2wlTk3`7OVo7En$lqCe(v`rKRfmY>Xq<3LaW zoQ64pcFfm58n8!&?fW}ReNAWWiVMznKJh4tPxoCMpf(`$sc6+_uf>pIVMrR1o9w6o zevoHd4u!%OlYWVTY5;j*b$!0Y$pGS9)Qvw7u+Zs+1fDO3CeCL!Ktx1>sR+HBl#mFS zVB73#!h4?sZ5%J?JX!&LJbBR?_a|#`Bp#%&;BTG%=u+;#VSl@fgweq3DOAV$4WFp=F!=SDo>Qg_PQK3n=vh193BI_Pn zH+<-w2-$-QUA!N0KJHChWL zl85?z1Dzb|$7A^Ecn=9ZbCj_U3`xJNtjdL|FOhDstOE}Syc}z4!hHzm7b>~BqHOe6 zQKPc)_x0M&dJy4qlp&){cr*P@B%lKJ~@B*E;Tht+;5#g)0oZ90A^yUDjYoSGzyW z-H3xAp)pOe2^~|%Z!N}gmxotU@5VLJJlczQ>d*=e>Zk@^$O$NOZ|Yh!2*TS6hlJN- z2#=CicZljpsfKpp!?5V*(R^hniM$x3k37Vo;f09H#h1;!|B+|_nG9=)dsO0Vi%5Sf zY0g^NK-v7u7+qdo`V`#DsxH`dS=EL7sLslU5IXwNqcDlfrBKVxWE;oZCNw~l$!*N8 zZWJ-=8Td$j5xc7^V0Ywg_dYBXva;4kZ5I}>lwO0^tr2rBD)c$A#+|{}#Eu14LJRF! zFp9IFnQ8}e*!y?tAzL7aM@@-{8h~~V|A;yxN(mod7!B}qlfe%Ts)`uqMBy{qJblE4 zw|r0`Yup>WhqL7()?JG~D{ENsN8cr0wptrhzs*!n+AriV8HkVb%vYkcA$Rd0Px}dm z0vTdd4lDWghw^KLFN63C;k2#G z7PgI25K4>H3^(~9f08l~Glh}F=#b5n$Ye4&o?HuDSP7#msR<^(O_|(bNAkip4{%p6 z-2V#_`Uk8kU5zRu6HnqIwr;ZeTsap_Wv**<@Qy+HBV2iMB&5o3I_qzD(jPnE$De}= z#8!6>C>Vx1=qeBj_U#5dT)e%AhzNHgn7_hTfL_J8lHPi!UER6DV`)!1>4nQ5oF})g zDt|sNLhD@m$deEQUc&^e^=}mCtP|kmE`1H6y7nZ|22IWW(-xtLnx};C!gVGnEix^2 z>#0CjIao%j%+uJfpt|%GsV>5y^HrCk??vuB9K6=m&me^)hrCaiQ9*&q9VjT++{&{M z+qDQ5;`8e;GL@i2dFb7$-uk^Vd{Yo#ZzFG43s?G>ulx*1R8#R&Peef>;0=b~;Muit z9LbXWSc+Z1$%8?u%k(6K4zmbBF;rOrI>G8u4=;T5HUwVAGQ-}~neg#y2^>CjNQpp} zAXh(`ghOUF28$}tQi~w+)xqJ<7llMU;tF<1i=d?fEAE&jaSb;7*LLgTRaV^5_w!3g zJo>Q-e6^Qw0%0Q+R_>8bD9W*b*8kK>IVZx$oUg(+`GScfi(4Rm2McJ884bG!!iJ3a za~s;C`18o30|)HWLCUzjbDETQCDv!Wn*?ozx^Kq6ed@p_U#E7lALB7l98wWA_8s2h zPd47arDBEf3S%3%m$V{lIu@$;kjLaNR(M+v&#zUb-i(2VNY7~pEsuh1AZ>EfK$nd? zBbL`s3gQ`An3(A0C;iOgMqfALyan9}-t;x>M&2C@o2@ZrcJm1WG%X^Vil>M*mwoMq z1fCV}_m4;T?iio3gx=5hEA7|+pdY#N5-Fl#4zSVKk1-~0#F5RB6RIkOcgMnf5LU=- zHOk<9?g)qvl6?6|bPPGqY!GpQD7Q8w%595ilG;_=HG?4Oeghx2@RT^scTw_TdPY;( z^Ax1ejJ6*T@MpBp^i2X^)s1)^P4(sAbu`W!omVE$F7rAX5<=^5SwUGhe~NX@A^fMstzo-B0Kq`KI8hZ~W33d8-#gk_e-FNmOHj@;ps=-IT8rUg z%1H849ku4X1=fM{1yE2C*E>7yepWcoUeGk{^9VwDXbV|MZO$5z$3P*aHpg^@vioC( z7bs`I%|^~bB{r;8*WXLBr?U5P@nv&Y;SNa{a7-jJ993LrAOi}zmS4j>z(+y&6yQo3 z!5~dU$33%|Q{`s7G*Z&KR2Nv6_DnO~KXZ>i-P!N-SvSGSU2)}eI^8#l)l^^yW2ytv z7YZ1%k^g~7YYA~z);iwb)PvNyrUq!5<*LbbCr`NKLL1r{o5J^)#aOF?q*?k3zK4rt z4teyNN_YZh0&t2{$Z0irTz1s&4qJ_~yM#vh`ajSr{j6w|(*hHi6V&!{J%#~9Us{Ht z;ugSEI0)pyKGCaf#PfQ{y7|tCysH(6Ga-v=VLi`@2qem;Tt#|TL?ElF`XbP_da{Pl zl*j9F z#&{V^zE)&y?*_e!s>Y0mY$W>9O<6CR+)rR`qdb*3Eg(dU;6DiyZoj9rheqdAe1u6XVgAV z7U(S)gyA9pVY*_zC4a#no@K}8X^|unx=4~AvvrHeNx}=8<${0>WS}3rPlwNZ;?X_#}rQ*xx-gCRyPLKQy=892j zxX4=Jhqh_(qKKZZP%_Q4P2Y+=jQpbzhL&@<9ENAhraNA{Tw0-|1tkm@9`cXZ*3bTU zEscX}whySY{H~4aUWafPLhSwpham>P0gN8hsma++;v~>M;Z~b{4j-$}Xp_UQMZRBC zeuu+1D1~-7&ilUZaGbQq?r=DWf%wJ*n3odboV5~8?voXQm89Pu>^rl!g=i_Y)No4% z#+LmKKGkDSe-v(q`mMO}Kd5|r;Z!^u5*u|aEDzThC-A#Mi5@ui;B-ycpK zuB=a}s_bo(7S=!MxH~A3=!w8Tj{x<)-<1}iZVIia6rez%MkcxC)meP1r2GaNlKCe))4ppu+!>Bf&?}^H{EbBy{ z#?`uDZ%$tI-He?m*`a|tHt9qkhmJN0R^#maHEymT{}44Sx$N&O+l#aFvg6V98!;jp z8IR}d|JSoNR~w#SEeSu9eohHR<8$99n7wk5AUoyBRfz792Q)5 zh7%BoZdToJn?iu)81Dh<#SZFp_Ef?%FmuWl$}G&BW>^k-8`Xk%XvWRwXul~fn8SY4 z;_r|wY0Z3z__DbJw??tP8K`GHfR({ui1|~tnXqFR4A--}<+idS{|FD}FmzQl(P`(< zrMEx_G!j4$cG0Yf4)camfU(J)58sS7Iodu1CuT<>I0?yp6qV~_TLIrLl6@3L$;mu= zCPx1!e;=ivl&(8?V&g4eeZkJitS@aZMGF&nL9477lW$5XG|F)oC9lKJ?iPxnuY(qW zj3xisIzm#~%Hk9MGm$cg-s!C^Gwe->4W`uIM93-=KzeA*<$2yY8Thv4HD4BAHn;6R zLcGRoo7{44Y*3zH| zoPSJ*r5RqHdL}&Zj;OZ*UOwE2*d};~=}oU}fwy11ICLf-yFn~&bm?a@(~>CTsN*Xy zB3%2sNF>*Zw%LC>9KZnlGFs?H1<=!gYex;HBdcJ5Oim z_}l^GAwI0Ej;ZWu{ zltT|bePG{-1{CygVd7i@vd=yxBBr1@r|_=@{wlrRbcXBbzoUr7Ap6^rW~8M zX>2DFj$l)^T)ndl!;W|EaZVPS0^w}27-Fi!F-b5hThPfXSS#6jO>PN6?!+?&EWotK z$7qA}v_5UpP1Q36pU8AmSDXgEUp#gQq(VlJFb`ZX4g zk$#zi`Ta@?d8Q;chCqUNjLAz0B(_tMY&$i{nx#{t+NrUiQ$jE7l<6_X>VR&|bF>ai>DuZ6Vg@ns3&bS4-%~zW&t@OJ^oo$aIE&(;3O`#s>fq zywVf6`Li_Muc?CmVb-IW*$rmS>jtj!3D(#4VUVOzc7Q1F^E=SWI^m2fm;ks7rY5;4TNiUDQ_M#U+ay??L_1G%LU@0l+Z;%ne%97E^%Ru2sKadxQlHw&^$6maO(xJPQi!aPwg| zr!2QiEx5pnso6qmd;Djh{~lJ2YoBy*?GujR5YOR)-2ipKe@a&%aeRT##cR~7F%H{> zeDbo(Dy8kv>ldk7jS0dz64S;U+ZZDGjU@Dh3F!s*5d@VGC|a%p&&}qJ`LS5hW!-!H zUNkIN%xhSdJTSwOjn-?U4MmMg*UL28f4?*;%W7UzvgYb**v0*;)u!r-nv#x}Y3dAZ zD#sN(uPGz$(J5}KTAQjVYD&6Wrl~vblU|J#HKhWi$dScOMYO4kyr$-1)TF!V1-+$4 zZJjnH;wZk|^oB6SClYgUyW`q!uBcr}DAVp=X}kSw*S02;u1{m=6gM@hO^p>b zB?)Dky7yk`Vo$g!+cD}}XrE4TYZ+~AB(F7&yd;zv`3>4yXSg-#Si8p1DQ;>|n;On* zimX8r%5?0>d!%EntT>yhwL}I{0X$4dAe-v9-aI6?C@ge}Vd+;`28v*jgfg&fQdpW5 zmgd4%@tp1%xZO-a)hMr%R8e{H=RO>Hf{rA|K5$kM8>l#z0PXLAiECcTl|eajH9VA; zy-4G(YiC&%E+5*e-k?=c)aKj0vjqlUd$To6)DW0n6@Jqqyk=89s1G|IwDWYr3m?7R zftRt&us8J?_;8yj4TmQLMc&2mASkPv+dBX+2E31s5rMO*VLv^c(eyz&I1&fPG}msu zX^GY4FuW87L+tEwDPQXv*SM<RQ=sNcC*yD;1O>{#n_7l3y@L5@<|aEEIF0H z!c#9Vg9V&e2(X|E1B_NOB8N^3<2s~eX<nP_1OC?;zu zK?{?71ftZ8zyT*83$pu!i6Kgo@&!JjG%a6XhCIH2x0yl=Atej}N+jhE!xzE~p;s7! zmm1Xc(tH7=3CZ%{_yU-3NkshmWn~b7gLE%4L_7m>cvTLz@>eP3nkb>!u>{{ zE(!&5z`@P;X}BJrsVLbmtO>SXw3xKv&bIxyRh#+5!NOtWiMYGE9**K8Saq5Q)&d$N z^7G)U0H=*s-JF4oq*;n}Seq4s2PQ5clxn!Cl$(4Ol&b5WnvWze-j59q>^rCGfi5Gd z)xt{v5nC5{8LN`o$?!o^I|UBkONhZ$5iRAw3-M`Er&t3+upRj6z0I0Ftm#QjuZClq ztASTXXo#@@59XD%ov5S-!9x)wi#S9A8(FNn)Jl<=nKh(a1+EKWi+g9t4wol8;e`CT zNMBJVy>V}eMf7X@2280%^c8k6Ay)c>^{ind7_72LF@rUzNMrZSV70@mgJqY`nb^cM z0_E4BNtEnA#BDpBUU<|n+m25GRb`|ne$cvP$Dxp!jwie|-3c$=DJQTJjeGIpsh1L3 zm5UwQ`$)FwGv~{;SEBKDK6A^@wq@}K72cYN_t-b4^h3Nqce?gQ_x%U=aX!%}TRZU# zctm}qZ3!}S4-yAKPmO1;InoBPe__ve0*}JU`k+wCckxzDT!#6%mP}%zMHSd^R)vpSwz8qDvS2z8G_G%an(13a} zxDy(QS&Q!y39GI1pgD_KbIADmF{*~~8BtU%sj8wDsi66D1q@mNcjX&^a`HK!KJX2St;tB+=|EYMBaH`>hG_rsD_iQM z&n26u3CF%|hJDR_zckOWqkL1O4ZF7SCX`RDf>mPQ5n|QQKvrIV1FVtIb+xXo%^0dr zvj<+h8E-Y=%kx#5lQ^FETqtGUmdfCL!hIjN1?F#gc~Bsf;XSjXr1!D~HLM(mr3M|; zF#sgjp*?xA4q5iSB&ga+_jbdo-j_8Ib;V5z+N^)X(2J=>>1Z>`oz_fHot_iQ-Pqc3Lj*q%0kL3R0aRF@SmL5!#-- z-a$HeRRnKaNqxx!LsN)a?LM}e8*Wb|-1`&mFLK}fIF6#=`U~-ZWSyZWXIv=*>Yqdt z(mX7xftRr=B|HTmCd;4T%=e^_ERxtW!jTZ%_s6rK>;mE?W)%{#~&rN?yOnmW5JF>Sy*#Pvel(-Ub9!W2{KJ3Y~74kUX-f z3X=kF4lwZtZv?SKox9yZq?h8~*$aKAqog5~bqkdbe)03d2UC4)Rqa@zIV?-W_wgmr z!wdmoD%VLRn92`$y`*5DoRvwW~Emiz-4D8tNx{u}Q9>W(`gK7Lm#- zkT$8IR+Y1I8cJ$tTthJpjcKS}L!%n1)zFBBA{xqQXq-k_oMh3En7d&d){vN^VWiiP zSd6hDt0A%3!g`<~-Th4Um^5vnTSKE7>eP@Zu=wtXhI+L177Yz*&SnjbYp6*>F`^aw zY8oP6MJT4B9?jXHA+wm&Yp73iRwJa}{dQB!foV_p61Itnbx7U{$JC<|s@D1@H8iX> z-de4`zX7yq`KIvMbjJq|+(NVOnVcqIePlI2butI#fvE2vF~W`{MD)KIfF=V+)? zLop5M?qjM!Lp3@K^%|PQN)FiSG&H86S`CeBs76CM4OMGMk6xrA8mcxVzfT~m)zGAd z#GLJ>avG}Bv~dYRFafUBTMO?9y=gs^(UoaI%wS%OgP7sGm^#E{@?z={GZu=$Bvlw? zrND-&gs>lv4S)6az&l8Gz~$6j-7Vm_sF{G-b3O{O941hRWs6>$ zwVU24Y1TjfAVUD}$ z_u)^F?1W0+c`cIv1AqMF!3Ie-fDYFOp@i327la(Iua+TqdkzQU{o*|};Vj+Nk|jME zWJ!1f6^Ml0Ya|@m6A8*CyzVL0e2A@t*N4}eEPx5GKZj7ly&)46cf8JVX2F!s!}6F$ z*5*axffwei&x;(<$aYSCe~>6uA!k#NGvN&nGE%c7yupDW1R(mgKxr|5Ih+T0jYbaUMOJGh?@$DIuF%Mapg(|f3Ty%W9>~inm%Shn z^Y>tu-^qGn|%EiWExe{u1^Gd*HBi{DnNnJK6!KES{pT^zk|RDk>SY|=?N4WnH1h4-GL%oCWo}n zK#>W$A0PwWBVcK*y$1XV%Ig6pp=2Ofzm^sSteyWWx%Vxi4p7p<@>PO)7B(J)OXDI_ zw_{`+sZe?GGZ))3;t5%&N~GUikYWYNnw#I;)|v=+B=D#8i6znsbH^iV&>o9pWkGUv ztKFNin|JJ{H?gi*gGD!j8dU~$iF|TrlzObuoIuq$mZ4?5JluK=DouTwHM`YEvx;-k zq!T;mm2KNv#dX26brn0`3+ zw}r_1%To#p+PTjzMtK{Ltpem`r=%k_^ zMK#O58f_V%FoCIVl!NRT(W0TW)b&urWf33COHembaZj8X51om-WR}Kw@PYw9_j1XN zJ&~!)*nnF-fMZyaWj9WCJYmHk#h_p-3;qZNQ%3=GSi`752oPc$ce)x$i|#?C#whY? zc=fd`=?pBl8A&~5La|-t8JSlejVAVG6RqoZ0Jg&ww&Xe#+?}vpkMp3=d(oTZ*hAc) zWcjH%fv%(*XJcyG#{wysuM_zKme|w*=s?Q=>7*bWJNb*WxUWLPpvNvwUoa4IY7^F~ zt$H-P`q3{4M=5h67ueHisz3)U)&5H{2%kI=bs|Gir>S4rH5$iNTW{9JA5DIF3GS^F zt^rN99gKRtx66M&pAg6fR4~R8sbyd}e*8h%Nz_7IFB?DtI|nXRUe+10OQuRYbZ~iu zS09SXgMdQ3pahm|7`I{~eK0nRM`8hwBmN^(nPGG62|U4K`Fs4(yg$ZQX21c0v>?ChR)C6*Yf?L{hv&9Gouo5N!+_VT*di_L5qvcfJ@0tyv$73g8B`p#+K=f%4hVZCtxdf zi|p&f^)h!J1IS0Bz>Am1w1&%PF2DLPd_AGkjA@zx4a}&S;N|EY><7EH;7p3t1+PLz zt!OIRb$XF4 zKJf%xxywUdN=-47%>DBRfz4cL$%*x|LY&Is7JfQjc!ifgUkw#mC8uafu(`knmkDcx zABK=Q12yu~SHT}%%2)MTc=aa$D-M9?oEddw?dElxZ^K3G%S~;- z)dmddXvb8a8V2~%5I4``;&9;y5s~}T)trtUa5Kzz0_%WaSy6)4h*M4%^3BTs;LK2i zU7db)?Tuho_`z7$N%O4O!Y_4!`q}f2!;S9`E~DV$K?)n>>B;0(&!G@5(zbe5DBOA& z>^dqpCZ)Me3Af%wcPNxVL1c$4kak$?Bb+6l*vCvo5s3vGf8e}9hjd!#C{g6p==TDB zQ)b5Y9AF1#SrMTZE|(bf=^3 zb_$(#BxLMkL-N+gZ=hlQ7UMVSc%_i0QA~RA4cJW`UOfi)WUX_f=IzqFuGVt{>+#x< zZ=f%JCi$a%Ikf=M!Z6yG;U&4xrP-tXJUoMtN((V|;IZ08TcYk4NYm7TIKkm@GMbU6 z2dR=ICF5P9Bw_!}hU90X?(q!D+k$GTT5%3O8%?Kb***yWwC@uY$_Im@Ah8Z!RRpFl z5SAGz=8t<&rMd*F9t*F&S0dP4q1^yOKDuvpkl+egmPA+=?#`$M^Xk4MrD%@5V4|)DTBddyaJru{*j$1=SE!c#}Hz zHvyedL1$OJqSGpP(3lxc1Y+QVAgg{{0~6~;3635f+wsT|!egiZ$W&(799xSgXwF^u zq2}DnS7wiQ^y3jJJvPOijmEkJCPL{u=V=^*9ST&@%p%Ok496K%+rL1e7&3mS0*^fS}=!K z-$Ifw_JbxapP%Z2oQibq!17s^7jE^BS?~cAOr5DtVcH}(;X=Fo5oagzu-D<{w`zfy z&pB?=YxC55m|YOQo#pukfi}{^Awq!4Y~IqW7UJN-x26$2LKfaoA|i}K#WBJWt{9^f zuIkLSCpL8rKFFFhb%kUx;_tsHc*}vaD1v+H*8+E2p@E}@_imjXE~&i-Vzh92ZD<74 zHiVSvIOUzqT#9)bUk+uasR_AV1LvcpPSfPwqM>p2VlxEh(6U{5bV}+u;Qna0a5phr zprXQ!qtALuk3ex9S|=3uT>~gqa;V(uN3Ow;Rv{rn`5Ra)OctPDG26k~5hXdf)mYdW3HzzNc0KJ%gdtEG@T0%WcF_$grs#5jtA#-7r$XvS^_;h|4Q* zxXF4I=vXsix+*Ce_zENg!AS_#d;W?RA+*u35qv%VBU4rIt-})}^^N%9F1zJ~!ZFJS zG2mmaw((iv*iB&X)V1XCj0mjor5E!P8H<;Erq_ciOdwV`Hiy{`U=98<&BkAaV^jI{ z=YTgYda7wbyo)v_&!W*&hse}J4XrlIswgVzl zmWH~mT~trRhub`u^zg`koZIk7RHhpF?scl^(3}xt%R5EUQ4QByr^cqCtVE5acJiKH zg;3D6=P4fi$h8#3g^W!KZt-pOm%($*C-xw95uSc2X(!>yi<9#r>Q?TiU#pl;N*us^ zh&Mw|SPqZH{v%VBRHoty>!NA+@ks?3g93sPjt@Z=r~2`yju$Xq$~U^_au7p2!jFgW zW9(iST=@1fAPMoDoCmT=YZ%{B8zci&!dFBopmE>QnF6sPxli1;o){WNqF(X0jFp^@ zKPV-OSimfVmyEp}j(wJ2|BTN2gqOrQ3R#4A?el2Xt**M7^z-c1Dts+V;_;eW6vY6Dm$QK4UyeZ7$qcX&-Ip18aSjsKIx*?M2`q&W>n;y^=B&5s3IE zwE7{XRfC5-wE94Y(5hMSTb#un2el|&a+1}j&EC^`(o%p{SL0o2wG~fFs|WLmolbq! zODn)r2Cd>`G+@&=Mnfk`+KIp@#A_i6zF!q0|ldq(r`wnflRN{sRlledP`4 z1eOIBGM@l)BA#Zi2S^2}Y8J7`^+p40qtt%K}PN;strFCD_!F4p&G6)^J4kJfEP5ns_075dywAv%6djD)p|%3f)^7DLt^m>e#}zwHZI`g% z^(dICW-KTy62ueHX%RC)cZAH6D1dS!wj9&~Jn|n>hw;c^NX_B9*U>y=c22vHSubn! z@`hvS^S+YVA3+BC^gEJ^$k!MeDoDX)XvhrKBtvEk_{3hNPQa52LYd?H1<*iry%mJh znNLdWf+t|Ou^ouI^Ky&fpvz{UoH}A~0jW6CDa+}rP(>C?9vDB2SBVSzO6%u<9-Qvy zP`?hBK6Vtu(J9N%v>Lqc!4`AX=KDzD|Gykv>9t)^Peos&_94xXnr6Al?Wx$gJynl+ z+c(ktTiby8>WKy8Arp_l!T&*4_*XXp8Mw#(^-Vwoar-8qyBAm!&>iwLn7rw<2~0o_ zEX+0maRK-+(z7{aLWiYszp9T^{FP_E4`Snd{0aCgVW1Nm4(x9*>686oT`ITi44)NQ z9*ngq&3kFNn&+0frI0-E&CaX@jPT9gC-&5qcI=G~@X~5Ut&U8t^xd*QQY>%jK z%?gMHDW2gGO|N@W9#M$Hxd;bOu0sHdCyt1LY-Ee$byJ$;3!*A7jwY0R6E+o;Q^a^s z@?CWqpuQbYdp_OManwNS;*vZ*-Oubq?vM16n7#^1ga8f>kH*L3GfH=YG-&%kAMXK4 zRN}EVv;|fWF>IvSv4A+*v0yim#->vl5qpYlJ&IG%Pu@UZeks5p-4x*WtndjN&kCPN zlb0Ne>QfFp;@ALpNE-Q(R7?mA`*Zmz(w|r(W?Q~rY~H&u-wnp7qH#KPIvDMX?{cy& z8;Zgv=E!$M0@FSg@2bHMHojEKPhSOoSOAkbei62ccR+@CX7hoh&kx0t|AqqjxpADz zWn7UH?;GQro&10f#C4{nlp`g{6jwTcw-QuC^x?5o9@XSh#BL+4Jdoxz!?4W6dL;VW zE7*eiQe=C@m1_`IcW)b15}X^w((y>|_Av}*gqGL(ebhCn%)%h|Y?m09U z7iG~xstyjgpPYdxXc2ZvI`p%w+sL3_&~0%!IE55gMPK?N39fty2jG7tkvt7}F_+;K z)!_?mqIeHj;R{k-qQ~{sV7N`l$qR^j5vP9cAgdMG!3ix%xZgj9ir^kvqI#jOZ{bTV z^#}wnCEiPWJw_b6!MhP41TnIrA5M4Hz#W|+7uwAbEi|t#z5%;A>1~g{#@(DxBQ#Sk zGxK7zuFnw-fKcE?V}5VGl$`}iv7ETBQlsh%!e!)aV*&(AQ?Fvb%5(S2?+Uts?0!Lr z1@j`EG@WBL_BNM52j^{T>fP4V&A6yn=W-o3?VOVsUhoih^IX=5&brlC;U_tFtGGey zJ!4|qQQSFVTT*z@tGCDB73(MM1^ivgvdx;>h9CZe!=KJTpXw(HdqaS%?@8sN1C>yA z;c>)&WU87Y^18O%apXbAML?Ty2KRGF@!W_}Ih0o^kS6F782*1HZHZ$p!SXCY$J|bN zVj9kZ-A7^?vb|p#@Y^X@ZUylVuUKybRiek>75kw)4JNN?R5vaxe39Ox<1@AZashx* z3umIMxrT6y!NT8zrtDxpk-E~h`l@vZ`y?gM59lP39`xmz6WAAAz%cW1JS87GDNDE0 zrIXJ`yr)K7J7!kV*@g3AF=(3e;n<1U^Wj|(1esWHmu!P2>GIt)NJ2+aNnBX+gXEazOrv5R=a1wlzV>6nz{6Q;#T~B6Nxy#ocN9aj4vx`~ar=i2PLV zji2Nxn3f=I>U|2I#KI}4+5~2Es1yajxG$C7wKKcj#|cL`profHI&X6K8*|UXBQ2I8e z#@KRsQ*A2VRf0EY6UFk=SD-m%YZJ`2n1_S9MH25oAvQj0wo)=6Rv4VFaRQ>gCG<`9 z6JcYhsiG9vAs%}5tL%=!wjX^XK2c9M-k`-*q8{uUYnQhhYUJ&PHqB{dMYFz1h!yrc z>zk!6fEP>duxxZmaH$>E~{IE)~@9 zIOtfJVoBk$N>C#bTegO9&ldNX64HPY^xdyR3EFfq^n4k?xJ-^ftw0zDu#Pql-3X7; zR6Np+M`GWom7%#E$$$g@j%}hEsI#nH94T#~8D3SQ{Z@H?s98m%V>qQte;jzR~ z*scydPm#eYZ{kprUx!!I#rdyqNBG|sO7e|kIngkbGs#)_PH7 z14=A5Sv*R6{v^XlFr@|D@YY8?K^Vyv+OXZ~*S~=&VZk^2)wJ1>V_f@FD;=|?z-WKs z;7809iY8d}X%tOe^Z@IUb7v@~{dF&W@vl-I$VZ;9@_Yi4&v@zY)nCX2NR38X4)7g7DI}{3VpSRTp3~&BrBf;m-hsaSMA2K%7h6>b(i!B^PFOF3)x& zEK!f=wCz^^5$CHUi&@k6@AshZO^5yh#tOjx&8+{C-A3PHP65Fck&TT&j62)7gaxlh z!BjQdz?mW}Akhl4UP812ml-mXXbc0V7~E`CAv0@j)ng`T;V?uOz%H>Xq7~>=;K~Uk zB`f-V;%tl|5u*>9F&GN&MR|t4`+&|-;FR`LbBRYe?opRcX(q-Tf0I%>Muu=9nf(F&tNV+~wdo)yQB%Kw1YPwDre;HO( zNWW`+=_ghGV}s}V%osAp=pNt^f>&3vnZa|2%g8P9JRrBA(_A$CJ?e6vfVtez2`_2D z90qP2bM_GNK4HLI$6PDr9C;c{HrL`xER3BjMJd^Sa!j^lLk7?Yh%EJON}+$0hV%^K4m`+b4~}gawzV&}SSiDm3Xzzi2ODO@Y>J zyjOIBL5xDJ3MJsoPQ(jWXJ%i5>>2wjuuI|)?62^4Npy^7tVhHpGX*z_qiBVQ-}6Ee zJ|#OQI-z3CR+T>kwB@1Lw(#W}VD`dTEQEIJHIcqgLVMDZKoi4&SDMJ$CV{0^X5UFk zv4e5}i}VUf?^upzskOar>viQU6MmSsUN2K&b$4*R-cD=qgzNQkmde_LaQjkOuS4^s z{~PGj5tiL!98z|U!WLV&L8?=-wuA)t2bxVFu3*INBf@6G76rXq%u=)KkLNa!A%p|z zNn_AlevTK~r{Zu-XYNh738Kl{8M1V~eVh`Gop2AyulhPfeJ6{~&zgI;8#DNyEVv2< zQyx~ewzZ$?XUK~cuXmb~B$UFaa&RxWNqs;jMCNNPZK}+%&%VNV>kFT6M8?$%I^P$x3 zZ=h~ZR5CUZCZLI96YrPU#5+`kZNN3a5XeRQehwnUk4^jxs;$EezxryNAR}grl*_YZ zCJL=ZHB*P_HaZ_+lTh)FokW4c;iKKdcNM?Z$0d7Lh0r{&wxRMG&;pFNN}Iqn=c0n( zKswlm^X1jrMbTO7Bk669ygrk03jc_$$``;XkbLZ`J3!$OgVZ6bS#aSJknpRC?TlHP z@;W;Ct;$jH3zZc8`AD640_6VIoKOR@e9g65nT!+aDu6+w+c)t0cR8VU)BbqIsMn5= z{)w|`A}7=cY!=qa^c;;E@vdR~z-%-mKYa=OfI&PbR4?9vG)xlaLn)*U%|D%z|Auz? zxv>pD(YPWfKG4iJJCTajW=UEKtv1V<;#p<7<-3?edjeUlRi;0X<~gCZAklY1v4w#B z<=Hb~f0^?Yh)E|VHNw#14}Ly3pD~!6caKiE-sabwK0#UWK~Sm_Y9hk$8=iy{3dUZe z9R=3G0VkAd>DcI;&j}@8P)X1U^%R^mz7y(+bA2b&5WeJcLVbnPm-99_p=vN!)9fR< zjMe*g$O*+7w&R3a@L{O(I8xNJnzg+hPN>^HD_oV^33YhxewBE`H#sL1tC^G&>e<7s z6RPMlG>cd7fuH22N8fQmam^paWuKgp|ItpUKm4aCwcw0qZ7#Tw5z|2~C)7s|<4TiG zsD0&WF!}D!{JT1#PCb-;p%bbBPszIKEW@Cn!PvzZ0+Qbe)dHI4eE4PjX3mFi!3kBF zCS&Mjw4#*DGdQ6nLvANj4?069RCASeLVb@Nb!YMeoKV-vPxW{3lN?!*<%IGgj?$Vm ze#xBLw6$dIkP~W8kPm0yM)Z{G@D%etu@h5Cse<@StnFC-k?o%%1>Xr<}^;IHoOIOi{*G1-C|6$m5NFoYt%O} z9m0X8Z^j7~#T%=zT1bt4HBP8XeKSs|3cUGFs4{u8PN-7NDasr|VD!y6p^Ej*GB(Z@ z4r(8w&Wxv}P@O4|LgIuf50fy-uJKK^+YS~*b^|C`Etfp$tLF}1C)nOz=C|sE zy5KZS36CwzTK^g!%G8SdPN>6Jbirv@0l#t!<-eP>Zo74|PAD-B-}f_X98TZ~6GR0y&3x9_G~@6klPC}{4lk7K|1jgQMwO!jauhcr znAECn{4XQ=CO#a5J?Wct6}}mLqbmujWJ2E>i3TW^c!SQ~BR_rJ`pxL&cfP~Vo|EvS_*)UU<*wNc*+^sQds)aYIG7)u;Y@eB{a z2zyu|eCsY=FmQq6IEl`*<2YZ!>HT^f=eza?((m3EGlkeVnG;U0Hg1HcX9NUdX#LH5Jtphv3yAAf7_D9r$aA33FfN}QI3vyXmh`mMhw#hP^!NT{WBoD&$qheR0 zc6i2HL*!hy`aHO{lfP}qMN@e~i9l0AJ1BfG3pbt!HSSh%Q+9~#ar7L2cnUz)ARz3U zS9+>ll-%y&V!DMn5U|ce!;%;(u@z3@a4}ZE$e~pzkot;n_+YXS9ZVl`>dYlx=T7bkA$UReAXh_xItQbTt&3ZN2(F{ zENah55=6+%lc_WKE*jkrBur(FQ92bS7o3hvic5|B80~LI?xHy%V0{1rN!y>s`(ZN$9om8{_m_{rF_wq z&wu}&h3)o_Ce+P?oG7*vU5S|_w<+&`BDyj+bTU0@bmbrdaWDrC$@DVOafF{PvkTjg z%hO=;1N&txY->O8PhHr`gkV{R^OA6hBmAQJRN6fDCz&ZGadhEB(=^=iOek!0)^vmS zpiLDun0GpFviAos(GaahA~xQ&7;jjU@mwL?Y1b&<^fFE?n(!uTvSxnuw%Jt3oAq#% zYY`E**ubK1cDkdNAq(Y2LzTITC$e z1=|cPe3IC~pS-G8)E}u4*RTO;uJLr)J1cN@>TKBwYdi^m@rC0AK^+p3ZI>YVVlWmB zLx|$gu%Wb#Don&a{KG3OSMDShDkCQmquroeStU+)@NGHTG<&P3#&VbgOl>SkSDWyl zUR3zDtaWm%b8O41pmuGa?Q8b3Y=4M64JJRjPe_&@3--?Bc51$s2(fS}?dOsOEM{Hz4>;9EhY+U{BtCA|aJWd}3hd=npuit#5HPZQEXuXx@m?O3#wE+BCI?aj@K0*z zHLJ-T^pZ&5dA;?$Ht3~9yY*gn>%rS>w=C9Amz|pf^!)k)VIo_D7(Hr)fh3649$q6i zOx$m_d|r>ng5LHu=A8mPGs+I4aS3}Bk1gin#1a2GToYm#(-{D6d%Ro!db4JuXSZIG z*_U{Xhc03)jB`DzZwcM+S%WvodrlG9R$0Nf_&~Y*^p$B&W40^Bn@kbQHMvw~m6#m; zg$f=o4?X(^m)x|!nYiWjPed>7aHa4@TNtrxJ1-o#X_9hL^|Y*Zp?5&F|B1E0N# zX$cbjiHQ&fCZ?A-F};Rk)^H&%@_9~lfkmC@QYk#=Ui4Y48YUNy5P9s1VSXOQD5`p% zt(td20(xHZXLqy)Fs)YvcZTKNoursu#9O_|0s!c*x<9jwye*`{1x40T-`N|Kc#Nyr zp6N@Hw`Ug2eZcqI;2tu)=U%EU=^)GVwHw|}rGocl&aQ>S z9?|KXn)(s;VL-OnB{=BApMk9<1GWxPiFeo={+uvv^x_WOWT#~n@i8gmWJsU-LW?k1xUG%F*5|D0k;oagVJ@rT#5;Q8oHYH9$aw7B-vWgH(`sbmq)J)^o25|CTt z%#qCU)^?pP<@DrM57q#X{dc4X#@oJ{1#dyY)X`U-HG;jblODdkL7l1j?dY&wDF!!t(D!2l`Dp8W;|1FM+QjB}BMRXevnw{@ zvI5-Q!+Bh`g-wN}<~%0p%;;Gfp@(tZBg2go&#PF6>~WH6esTE@Kn}nQv@D-eD^WIi z-e<7DY8e>9M1~8hK#~*yy(A18yPp+l?w#QpbM<}9e*cudx042$|1s2y@}l?f{U`cv z>T9|f-%Q!2lkm)KU?|sg0G@3ft$)x1MdTd@@aY5)*FqqxK)q2vOHq8@S}mXX%Fm;H zwh4TDM8B~``R3xAfP!zo&~JQ|YEP%mV<5-pYxMIH`}x!QS%AX9|NB^gk#&h?^#FW> z3WYoKQzfE&9~b6N^$+kS7Te?%hs%nVK%whWlRTrQ52wSMx=w4lL#jBqSZlh(tLZ4M zNibn*l4sQP1V0T5ex-M!HM%oDt2O;{4}s}aucp5pCNL2h7AAQ{O;>77e3hF1B0_!U zJyONNOSPtIuclkICXy2aY(WF9>w+p8T(3^S9H%UKHZsQVPVR^5^(MptCZM$Q8#@Xyu-x zq4t(Yb7)T0navm7lR8&P*Xp5klevu{b8ThSDc*&ZP4_|ls+8d$=%?!@{yLkbVui+` z6u~+d*e#Ad|M}E8u{juk%cxU19p(H9ZFC~$%E1bK2X!f2#>-MNV_4e6OgsjwL$3;r z&5)#(5JH@Dx|!q*$X&}Jm~-7>CdjQUo8gPGR@`5&)CjSAPf?IjV<}R*DM8|0J^XQ^Wk|(x!R^)5eo3u|9j~SW zntno3JBB3H{Al7VbYj?UJq>!8c#lOHPO~RhOhpxB^3+w|L}PCCl4+d3(WfAzHS(L+ zgZi`{D06o4>}bGhd$3TT>RPO+wg*czb-AQ^J!qEHjy6d(KXR&dbiy7iz;eX)fIy^v zc8T=hrm392***9_ErT!PH?Ifq?L(m3F<>TOdz?Rh4+;dTu3~}88-o%}E!ETtj0|Yi zEz{I;O|3y{6sZ-OS}CbD^+0ruJa*`h987PzsBsQbfYTn0#0OYJhEx@N$z+AC>=5+?$l3WMpb$^4$^f`&QSOH zNi}%KMMF4z01%r)@CtG9P$Hyfs%MCj)az(eg9~23Q}T{ak!q{2MC5t$Z=b}o?O#nL zDn>BO0g<8brRTxSgIwn@*VQP2PeotdMT~}#p=1+MlHK@oIBuW(D6%FOu~x4pOFea{ zAIj0r_&5>uJOO4;ryiVIBI;3W4*H1Q^bn+YaO9P{H$d-V=OnAt;!qT)s{&7$x=Vc^ z>M>q$c{!2Js*O!$Em9WOk+Vjad-3-$sq~^Br+x=oi8>8Eut1UuP$If$B)g41Z9^_A z(&2%KM;nE0h~TN^qUZ0X>e_fyTP<`Wq3XHr=Q62UuAG=ga6x9DKQI?nlPR1&A!;7= z<8%pO!vPN8IO&Vm!{7sysdCX@YOA)cT$G2_>*xefTL0m`xoQ1S00H7Kv>yJ}8qgTu zErEA}z)dvH5fZ9lXuQ%NDA2fQVK^W02nO9Ga5!{D*5|21ND7iX6dkN1tI?&**)zo} zCzRwLCdqGxK^eq+R|SZ9H$HoW>XZDk>B!N=96iX98l>b%%N7{|%fj>-pgb(~*$p9! z5TTyp7ZJ*6*n}gwMt>+Wg^TF-=n}#Z4;wFfU!gEnLFx_-*9m;f(PEI+r)JW+w3hlD z>hT&}%-V>6i%}si|i#y8Z8*UOW9)PN$254a1&>;~Udb%8)`+yI+da zX?uSOL8NmkH1tb83&TZUc{%#!L`ihkrYKmkC9w;*eJ7GIinMt(G!L_^(|}3tQQk5V z-<%8|@aDEal_Qg@ve~aPp;b0VdBpMKs4^OVFnPx(-h?5>3>jK9;|~XhY5?(%i3~sD z;}gqpUX+|J!}rIT!Lr0nhyXts_;I8itU=x*YuE(DF_WtziHn{|y#_C*xh>pj>K8_H zRv|KqMD3!dj9Re;^`VrQ;U(hIrbc$ zpjP}p{7|hJ=c{HfP^ty>brn;nWGEM7rV3Fm(0pnP6;ccj;f5xR|1iFz!V&zieHF8Y zP6mX45T7QD3GE`h`Ye{l@|LA6&XGV3ieKZv`MKe zn~4QyPX;?KqPC&Q$5lFevar)76c5+Qu{i$@mV_lNC2RJ(X$Zx-6O#KL%qnUV6>np? znz*#4no4uV^~Z=@%(h;)%@@q*SiYfJ4ip|IGm^M#&5k68PewA{A;Xt8www<2qnQJ5 zEDF>Cx*DkQ6iz~>$9%m|@DeAY@xQYTU{dvl(_(8_nGYna(Q%F$qK#WehEU|z$= z7*ozs`lWt}_t@4$uy77K@nHP%QCIkrq1q?SK7QV8T$TKoo)bRj^$;kU=Y*gC28h$G z{xW`&`+ghGJhIrZb-3*#SO<7bkep$Rl53B&eU9|3jW}1QerAllO0o+Lw1T{ac& zFnt6#-O`8L;S-&;IU0HaEA~uMK~zK3J(?r)D`s#H`jrk&9R`Q_iFJ)Ln6;sn8JPbF zxzT~)W1%6?lM+%oYqRHiu)pzLruE$2YYK2*&Y^H;j=buz|AD1e>5_?{@No~f6W2!{ zY@`j78$)KHi%AgirI+d6Zog#^SuNuuRIzmis7>c+0iw4;L~m`?ec{ywTp3t`nj{z! zW-Mxw<7y)r;w5w+;GFhuP#I2akqcXg)7y}<=X}WjW!N$u%C{iFa!@EpD3dIWlBw5_ z8~Vc>eqVIMQ#=E6=4Rj}prnZU^T{TFxV*B!291Um!xD@*|4ww@gw?S(OWGuc04-_U?*0XpX_A-|qXnffFill$%`i?luW!xHSw56B|T^l>@BR=dQq#h7}=5L=tv z3AvpLoaXF%pNo1SOz~*qhi2T1~|Nb82(9=2W!WR&*H(?ODs(#qD|z;+o|EqC5y$%@U-P z`6-~VvAN6I*P#sXOrMao!ON{v~uDz3x_luXM|jv`yqQp%7* zLFiY@6=`>1`8a%6U`6^$-W4fqZR_W_i*YcmHBo~c#WcKRZ&?`5+Q(ZM&Y6{jRXD@< zSq_yj-S@d4Qa0**I`~&S3*A ze9?x~ud%5O_xtp)4(`cZube0hvy)i)uz-;P4q6DC+d1--N+?C~O77LM=#oK#(G2Sv zrYdr~1na&R5?eIKR2$Nfk;;r9@U78c?}Zq0v^7avH+;LyOS=Ir0s-4MEt9%AQ}|m= z*+2nT2a;k33E05QU`7mJaS7nT$jL=tdYjpheQR&S+u5P08(C97kCz0!FgHG~TEd*? zssBF$o!;Um-TQ}2dO;`G4*V`H@sV>@&)hlrgGRdvc0^k_sF#IJ_V~UZM?A)fF&{W*5kpE z*LZ9%z=2zW@E6MCzU?iN44W@AYmvibhrmVumHG}U0zWi69V`@G^tc>0sRlH3iZkaB zN}0z59*gn3Iradau!Q~07wb1;lTh>_|NYJn19yk}2^S2wXFPJw3$OIS#tEq8a$lxoX8 zV`t7^^se&g>=ERY0%-ANv`G8y?=mZ(%?L2GBb}h)vDtz%C?-92(4;CpR^dDF;o^t* z=;kZ);JiINBBj%&SU`1cX8aeJ`tY6qU_^aT4je}q|G4}%|+F}oXc>=LQN zNF)vdtR3I_69<8ZlwKrHgUPR@IAVcZcKt?pY`S2^h=09mZm}RnTdf*d`aTZ=x$0)y z3=+E-Yzp&THpYZbnXTlw z^*Or^QQ`O*CgobEuGtb}{7ExX4CX^?oI$0Xos58XD+OIMsQD?9{fU$svzJVSf#|3W zkCEI7B8>eDSzOEy*d)uVUGUAf^~<%`kI6ozbc}LemFOQ%Lw80KRBlPyJ4jcs_ghxa zq^mUM9|ypO?y1RRPth2=fVfzWAPxq?8%+K}McKf;ZA{nE!&U=K2l4{y0!Dv55kv@G zC|3#H*!`CiO5?S6y5zglMbLd@s-CZ7YV7{zMU{Si5xc)Wsw>vj00H0bPa&Pd?qB<~ zwfleL8Ss!>eLjAYvsQ}w54*q0_Hf$+(1m@Vgow}+H7=JC<<3C4{G<_x8pNsf8uj$v z@ahAzYf7`5d%Yu_cItJ;98_?Mm>abP7>y#apP%x zExh_`vcSut-+v_%$w2&D;j6$D>hqO2P(i&Tpg3VBB}Jpw=d?l_;uP!~A#J8PE1CTv zITVulxh<5;h`F8l6rPfgKb=KJlO24qMF$5GXaKjVHQE|+g+hXvFxv6h3?)#d97~`X zj8*C*S@(fzEdj>rwTc3Pg(}s^$)^ed*UZK zbYUig{f?8k72cH6&^K5SFxP`BjEWI@6Std3!z&ZeQX$lvU{uL99duPvhNvk-`w^TD zOf0z3bIidRn4(thp|cE);0My!tII+{0j3iC%RJ#Pi?nXL=mGLk!iH8$DH~J$eN|4y z82$(&wHZt$W^_AUCD4De_!y9&Ey}tH0YE2WGK4Xf1}aYukjd`_L2>leB+tcPW?g_s zj%1NzqquH`aUMZBO+4L3B%8qVIl|-UG5}pO=J%|wsc{}it@IkQ9S<7k4UE=4zhPV| zm+{D~JTN9|GzV-C!3J-P=EF3{o8_|LU4y1F0OQmi93e8OHS22t)uHTPX3XG=FiWdh z|Ic_z#&(Bh<5qu#k;nJ$_U5*h6`Km0Xp29YDa-KH>El#jyY99XLSRf}ix+02Eq+%u zpvgN_;Zf8Mk;7MvctPsVF!9K`pkb3Aoo_!Sw4{70s$61@FI0Sx9zWY3K87&cXK zO(0es9ET3x8caU3Ypyi`))Z8dpmjE~GCz1Uyn3AApXS3nK7fEqZrCw z_5$IzXdVlM*2~z8rQ;grSI-2l{ce}xidK!UJU*T25lSk+!6j^Eo6gVHU!lT4V%HQ9 zkMPuA0o59VPd_)VfYenhIdQA6uve0K?vn`AZ;%R%gUL|kC;g1DNqW(&+SYL>tI@1M z%G7AqTiI|XWu{woD02(Qv}e*I5ulsm=kabkERkt`^uN-Y8kqg){|Z9xc~{EJ4vZR2 zjq=Cw{3!L3+R-Sf=0^>%vnKMRd~X*}k@2Gth}7wSLA7r6UqBJb7mCSa6GW4@JhwO+ zU(p6`pl82kF^wf)??{_da}i`RpK6_j3-xz#qy8?b=P&cuFn>SaoSNklCa3A;Oz+X$ z%h7GdpsAU|JeNRUrU=njP&G8KxI}y;&)r$<1|LSh;)5Cm0&74{+rd%br1bc(O&mJp zz7V^h)*>`qW0V?jQ=tSXu|)|`LR^ezOI{766h(2b->4_DaT;j1@> zZ@*9Do~UovhMq!X5(rVsMj2mn(9h6h)g$3G$obH&_r)Gsx<@;psTvQjV#xXEERz{~ zfl78`%@Rbh?051gs7LvD!=};ul3xNAFpBjE3{U>F$VkUMkn$O(%*WT!`39G)O^pB- zJQ+v|_!o6$HKR-}<}q$&3h2_tb~Kfhj2cqF(hE#=?5orDte1n!arhzs8I<%vlS|QPAlOs zT71V!`1e=|-z?ym<+Bnle29ZUE8&UqG?+XFk(r(np%Wjb2whlu={ssAd`y6N5_aKt ztc2pWe8)=I!+HGQ*h=`}2dxpKVHiB*R@dPtxzpKrmgwMrPb*;?I`NK`FwdHL3rJRM zf;e7FsdvPty!}?f%@0sA(@MA=Ps!UJ%o5B0%dLd>+;17|X`;fdevWv!?yO7(o4`u= zO;ll2jNife^^TRWkfHI@egH(iVHNji65dGb zE8+6Lf{Joj35P%t$@^a--=O;y~@Lt!rPdDH8X(;wdlL| za6+BVb+cCI1)0^12^qY~A9GSxt{}7JS%%_|BLzoVNqE@_04RP6Vgeh6)XjkiT@#l? z@1NLUG=A4SGF81o7vTwh?iKh!XjG(K)z^kjp1I)1A^i&83I#kP4rw9E`P(uP7cIw@ zL|t=s`Czge9h)169o}@D1_P+9yKbcJ_9uFgPT%4yUa-VV$=a$dO`kHzgFU+>($8?8 zWz$>k4jtCT-iB9A#oy77nml6bE*RZn8a6ezqV3xFv&nS`g&w`dR_B2dg;R1mRKBll z+!{W019d-a{T?2RhHp7Aim2}R#%R@8)03mqJa@`BsMBAviF7f6ad`-zqZ#`;WOqU( zab=^EYq&eXM1QCsrKSui;&1WtFs?EYbrIh#XWOusB}K>HZD`4jbR)eN{pw}<9yZ-8 zUQF|NY4Z2~540um{>dwGz*{`_K>&iYVX%P#F5NkJAyw!ZAdHbh!cLOs%ZW4G`ZMNK z{dsoy^S_-_l?=Pb!12iQYlQ0Ptid5RYY^|Q+gVLNq**va7~BM`jYC&~A(DY`1^qf3mVL}nfLKU-mhAzA!yp%r zJdnDC1gqpBr%V=%K5dGd*L%FHVhE_Z>CGsXfOyaj;}hi4AJCzkgqi+X0vrgQb)OGO zw1D*6EtEan8Z{KtJAHlxh}4DNg{S1{(jgNpPiI^Sh)4Pdqy&;rC^=JvnM1nz9->=^Z2~|Sap)A_LbEPjV-)}OuGk-{ ziNL&!IKFOFp3wlus2&_ZPz4SgJ5U>f$dj$)92PWQILu8UKfQ}VwI>i2krC9!P9m0b zd`h?#3tl3O!kpnUvKPVG6Q0tlhE0}1n<^c6P8l$%4MgoeCpIv|29EX`I5jdNt+Yfo zg+}jeM~=t{cD>w7$_#(26Y-CdhJjk3IZ4mk=>pe21%$aNrU?7fFqy$iL zgeGiIP+2%UI#ZAvK=}UHMb?g5Dun1(&%~?NNp_jIPA>hmzunxnM0ZPf_*+jP@=zM- z;gcvddv6>M1M<&iWxQrl);-FSu26WkunEP?~Nj( z60(1|(}OK517?@C0a8q-bwbmYoq;&?!~*h2fScm8DzbLzTs;h!F^%5UJdsi!RK&># zd&x3C9E5GnE6Sl=;r~d5Z2uZe9`S^rwqlM`J_y=}G?`O%uE#>*nC!dFT^}0?bc)^+ z4-gf4t~6N&{;UC_qi&?xwEACndNYHeRZFw;WpE@hXEzYEy!~bmM^EegW+f_5TfbMf zPQ1oRv9M2iUhWixA_?+NY6^fvR9&D?X+p{Fy|x61K?t{A2m--=DJVE^%W&NKIHqkJ zR3+38&}7z$|9TdrD(HGs_tRiOw&oIPAcNj(OMBSp@%gl_BH{ptHe7ZP{R>h{n=>4@tkTzzM;iR-C)Ht$lQt_R+$29JtgDHG#T- zX!O}PB zBlf_Z!w|YiCVaA!11ES5#%jTtHjkKy=-{+1Q}q44V6@e#XBgU(=+k5daW%ITFY1LpvOP*as;o#Oe8y{sN3 zewT`o@UfQ^0atF)8g`pR4cABw>_J)$w`mPUO|yvGvw-K^uy8}7XrA0d-JcDqc1o11 zNPj%CUKK6iBQ*;An1PY)_Z$LF6f$oThdP7KuDU0@mN4R!^s@m=6PS0p?7uKNzo&zx z&k;h6dYA&o9P8=2K5y|5Uq_lbRiZCQFGE@vr(0=$w1w<13YJ7znVsOA+?15vqHVlz zM-D=Hl~3-$uSvpS^0=Rg(Do0`Swj`tgD+d-++gZk%xsSq~s6y^=2KKxG|U1m%|4uKXE^ zZ7})QAZ=wdhjye1D9KQE%Mq+1b)se7dP2yBy!nv&B>uFcW9@_TLAfofbKe#wWHS1r zT4x21Jn%aU_CA&P-? z*pDadN)`~o*FrQvOHnyptjSm~GC8p?Wppb8sx>`0ibkSCs)S=)f@==J(8th#j8mT8 zfjyiK!X)fPO*m5@F30g-QzjnjT6YGSOov$+%}1? z54M00HgQ!OtXzRLjRm<>E(h{p$mkQ~#}I0QsvP7h)*>{+ht%B|9#CdFxqgd@C`B0x ziR_6pH8I)`a^!_2qZsHBA|X;SfrvKrm7hdGTvQio-42>Ev9E}O48cN@LaRb}pt0HY zC*mwWT1NO=!QX97B}!t+Gv6iB8nnd>E#skZjK@1q%uQ2CD;;c2QK857m3i+NVwEK& z7^#nuKyD;~czDa=rV?3pTC^&Kq>oOP0Ft$#%1~F&ZFGx{y-{i8<{O1Zq*2gF5~F&L z(g+7GSM?jcL5J-~;nYs}L?I>#`%!pAn2^T_XAV9ltJTk9faf?jD&H|@9tr%*bjd_( z@!KVO%*ixX^swrH=z(w|=Rr&%R_Q#!Yt$#(scB>Yh|59CcK9uA;Kp$^RoM^T{5$$x zw5&P`DbKD*$$hG`(C#)bp?Rhkj2?(5EN8HCFBtt0cIO4u(B(ftpPf4J$jo#32qody zKO(L-;nw#!5JnoalbtSFJ{cx9m`*~4IZB^7Z1i*);h?J_*@exW9ac7(**k(M4jX^m zj#4Snr`n5Dgn@Ya#|p_&ghT{S=Ij!{@0TYfoQZJ?*&u(K_YizjB}KnMn^f{VUKO>6 zSv&zf+R|?N3Q4y5KS7dEftoXiK25(nl5}fDkC`cTiJ;)jt_sYOA!b%RoZsbO16~7p4u9*1MQXZw z55R})vRi!RSL5n($X!ucsZD~_FT9=uz|&Zl^2t58NfHK=zxsY2=%xP|9f!D z4g{+JsbYDuum+Km*>XCE&ULYr_SiY+YTA_}fYIUtX_2&Xf@!-C+yT?Cwry*HQUjes zNG{(9q}oNUEBSi_1ogy2D!Io)Y9U_04RW3VXXew;ys9|UU0>7BN!cD#2^u{8j_YX* zNQ^b3XRY72RDYp74JLmFa%V4CJ+a$}jQPMTz&CF&Gto^_wTzwl4UFgZNzJYt#aZi4 zd#yWEpvN(c;fa&(?$=leWbJdirSXfWSB7IhBDspN0;&ch@Q4=_R5htdL+la`WxBY> zJdUz77g&-&>f~cCQA>Gq9$j{-y{e)LTy4x(vpHvhbGdMT3m{9K0i>D9Nn3+FtZE3r zO1&^p<3Ry3#Z@wv%cqWc)XRP0syELVbHs^;;-N7j9k6;I3&#j6U>Y*L@V>AZ(V>De zU&(whW%P1Pdbz*$lC^r`Cv~I{fBK}7x*u2H`eF%2>%22b)7L#>!zg-|jSRcr)a{sy zXi&0NK{XJ84=(zi(%cr0<^*bjl3FTV$+zOtdrm#Tlr*^N;>0F>sfw%#w-#f?p`J%e zfUrO3Qd$EmGs#IQMKG8-OG?RFEzxCp_;z{XT5TPkl6zpytA#-d@z@){z6U}c?4`Hv zWwPQ!h|fq6RtL--;k8~VPlL&;2W+zlrV>%c*2jab`>Ht5oD&V6?yeau(mYgT={0Gi z%EkcO57+9b76BqF!wNncSrd=FsL-TWo@YcvkkKCiKqm=DhWg6ZjQV=vdW#$x6Cto4 z<2=hW4j|W1geixo=~4+VS)uWUD4h#Lz|sW`Q7?kdo%Wq;6d4~xc-TKymp#C=bXBMA z0+6SoJ2gv~No-n>Sru_OR?-|ZwZq;(iFQUC8}6@&f@O7zgn4floYKONC|(a6dX7l! z^q?y$1qixYB0qZKcHAX$YH{qO{D5m^mSYye zEhMg;RCp>P4p1ZUDc23M9SI3}f(;`i_+3d3=~Gyg6p5E@2L%{oBo4DVZn>tC6x4#^_W<9u8m5gIk@*!}+*0yDP8aup85r zU*76>#UF%&(!0XYucFG0R0xBEu)Q`jyYfwGb}%^&UD2|l#$wKRXBZs11|`cGYM*cL#C9)ysF~X)yWP zl^l=$Abxbvi;{N*nk9rXK3|>ej(QuOYH-6RM7s!(?6&byuv1DSbtc9OFi@jkUwZHK79I6@QgS zV8Vb79L{_{Is?61;+1kXC%0v1N*jwq88Shm5;v&qM6{!rtd*z1=duXEtiDXHsW z(NCi<667i;W~=piCD@AJJ|$HJg@EBx;m3!~%z!vA6Z>&-eq?0Is|k=X_bQ8w&&m@v zUw|Z>oPKQ9W-h|Zo3|;j&fC6$Kq)bjgQqRcGEOIQEikoyT zbO!|FHCJ%729w)XX9~!y?(dNBI*5qyKsQq4G6ZgsVP(VZNYzu(W1`mnYk| zV3&|`-Q)5!m^?JA6Y0Y919t}6-!UoX4WOu4{&>pks=R#>oH2+!vy&14WVDrrRnQ_x zGUf9`lGUxB2PxMx@1$+A`i3BT^>W+Q=jCZIIScDXBhNl`45HJ3(i=$j`B~VEr?)V$ zXw4zdzU4J{k!kMtmkSF^6V~gWF3*06oK~J~#QCFEp4}wRD$lON^LFIfm(Z6?dG-{z zfbwjSRFxsmIHl*7XW`fnQP7AyMru7weLRsLLp0%FAvYNeow3>u$QR^kFnK3vPlOyh zZVV~)w7--f74AuEAj0Pi(Z^wHAKfD$Ge(cV>ZJ+l0@QDJ+PF)qZ4k+H@lU-TVc!04 z`JzjM>wau?Lxku?<5Rf)Nd}`y&AsO>&n?7Bbv@BI^wxL-wsh6C*CKwcHqIlfBi&|| z!>N1(8(r~J?#<}!T-roB8PaLoox^x<^EQ^4h)oIEIs~9tA_|mj6RC3kA5%981=R$!Nn|1k#K3*J@ZYHF@^&TYfA*bV~3_6V+ZB0aNDIDYo=vyYoSkGfV< z#kQvMZB1p{no1?A<%K%j+>QxlPgc~jX(8!wi`l1W;+hR5Uh>=)qB1^E2}Kv{@Cy0q zD3>3%3_nh99L+6`iVqJ9LJ@}K7FqpjXQYZ$olOYe1hyl`_e%;>!q!Fl-)ET-7FNT0J1uZe^ zd94>P4H>icFfm-HMyJZ)yUH1Cxfb4dZcAv1tbyvj<}hg_eEF*%p?=Y=+Jh`ejJVR6 z;u(OXWq^No4zFPppyZWcX&yJKc@eY4eO6FQB~ltP8fdmjkqsIlc#FU-2oPb7m=-Zh zth35zIOZb7o{s9vV9$IdL_z`L>L9o?x3m$Bvc|vRdT(eW&FTRBM5Ot`-Mz=9+#67| zXPo1+AkxgKt63YQWkpbjijj11YMGp z>X`XJ$Fc^)&#|1Y`>_lXOeAAaRhfWI?udCHy>yYsCK7H>;(8MiuFy$DW@)5Ui8N+x zU=l)(d~!n@0O=~G1azyHq1NP0$53{1KgcODrW4Rg3>@;CU)?-efi$O&!#${Xd}Bl% zc?vkU;lz0kIjSO^7tw?zd(eeX2P6F?fzcTR_w#7irc#DzA&{6NtR8s`ANyZKR#iF; z{qY%Xn#!45T1zznG)``%zIbkHCBn$V-{g~faEm0s1$v23h;Wk=S|5Z!PxcQs?Q}37 zgk?o`>!X|4G^v5q2}8m(ujyU1>0;CLLNpD{LT?gu=_hNSAZV$6~LNYQpk5I zmmHRH&~2wx6Eh9?5HPyMvfH7o>Ej-U!)_2=KT1A3!84JM~IlXBPs;#AliuCjuWe4QWv zbPQUA2slgtU-^FBnW05yQK(Vya9~Gw#fv_A*=0@}_WD#6S*IJCI2A5^KeBn`+QBBz&0GoWhP zq23LYnEk`Eo`_B$kmIBU8xx>)Z;I)Zu+@+A}O5l4T$q|F_-=TZMU~z z?-pz~hl#XaIRhX-(yhLWhD4!pz~T+-h){0}B#$z18rJz6 z9ntraLR=*>U80gz12{mQ&-+4J#!|_cl{6J)Pj<^d6xI#UjEvk)en6!80%~3&U|>UT zSQl^TF;NAgH7r6QMB^q3aE&dlPI^;3Mm*8a$n+>5FDaL_iUosYAgO=}B4& z^UQ$B@MIVh=hKQU!yW~s5($gX(+jc55OZi}yV*1ccM)hjm+VdRAHG5~MtZhGX)+f@ zn$a;z3kN>ao_K7P&{oc(!+wa5iV~SMdsN@dBI)ehC6LV zJCLVM3cmQ?in`mi-#US)hrXXlPKR`IPuzE57+fbPFC4Y$P;WL-jt37EpEB$Vkr@`dAz?ohv z3OT^ETR0g?OMk-}B zhQ`xEiYtKu4n_cc8IObRQ2`dI$I&ZZzva{6fluR@O1n{oq3P@Pod`rL^u1}r8%Chu zqnwCZIUbR9ijg!9Gf2wQ%NzxAb`;?hwXR%Um&KWE8XFf(M{a&EtT^{0hSux4G8l)P z+gv6XbNl)28T6wFL-sIEjE+nS%ZZD(ZP0JrXCe@{Kj_W>yg_Hv{-FQjJs9*y7}hJ? z0IW@V(9;?Haj_v935lV?z6mrWKAixcW%D8C7e7=5@-0$*mHbLM2NH zMEKQeKxAdZ=%`yhd5cEU z;|@0MbH~~l;EsM+_JYHWnRolMV1`6o$~v;goWo$zVFtV$#)J9z-!A;-%YxAEh{}M2 zi)U(h3u>SIeCzL=bvJ{Tb3m(fk&}gU&lw16j!uSnO8+PuuSc#iuBlJYSVsBLyx~im8IT&tdCs`X*tibHiVYqf>@B2q?Hp6hmakcCJt9x=e}B~<_!8CP zt2VA&U}?c5Nf1u#9FnXm`VzsKK2}^_pe1HPOBZ-8E#Z@U@YhU(_kM)~&Q$?uDs7Pz z=?t$rlG=KJ+@Z-0V6 zdx^#RLU|&Mo`|Ppe|yf}a(0)7K(jtF%zXAvskfZl8A{#cjglJ;Ssazb>w;#4 zaO{tu8bhS;McP4Ci)-4bcuUuC4A2G!M;fO5w-yMQ-x*_0Rfw_xW+iKHDue}M{*Z;n zx5w$$nS2Ep(Nxz)O9c%)0FxO#vPpe`wi6Zns@v2czaH5o7LC+y%wT$Hwr|NYmC=>G z+G#!RtCTn^NVgL;%}KNKujvzrFmN_-16>SNJPEB zj>@B&fS|CT$zTLnguG%nGtwJweUYOeRRH06EpA!>?F2Jf&C?iGWcLouJmA;O=UN(F zFHeKX_ai#Ns|EN?1DnXea7KU?*@{Nk^LEPn;8{ux0)o|}vY_!paU?Wmj2!BgQLE}4 z_iPMdhW+)ssx*K*6oRz>tw?L_g|rYtjlV ziF%ZwSP+{*Ig#NDN>E9>VLghf9dWqj-0MT5mxA`!v#VLXq5&dPt;;rToF=k16C+YK zrxKsl%=K(0D=UM+?}YRv|^BvZM>M+ZPOio|P(B+2f=u`vDYemJA1o%P=f) zru#)`wrl+rh>mnj9y4|3%FSaEBJHVbg+$qL`1s_!+2Qo=@C+j|I(wZq-6(VuM;IK+ z+NHQ2o+F21w0;z+9$lg8xZD-2x&t9$Q@JR}C?5ux>>N1^(+g3Z(SvVnBh{Pwb0`?L zm-5NV@rbb??7G+r?`>b=6BUe?@RU4>wc4UOm|QuE`M|VAN#^Cq(lIPVX|{uwNM~qt z7aX|`vPAXmqIWLc+pthR8?fZ#*%$N*qKHI!#7-H9vigB%z#oG`zCga2b>1FF-e1nL zsCh=729wbFpFcAo?>V36nt&h(w9d7`lC z2Smec!mqXLiq%5Xc`3^Hn~B!}dIp%pjlsoDfZ*b0mFTc2s^Z(O?l?ma;&IJyjK7Fz zOFM|C6^Y53>rqw?;z?IuKLvO_pN?5*L_vgOw{t%Z=BhxrZHJySh%{~^<4N@Uue{RoW+;4l7wdd?oZIT-51J3Lm&2=LNOv0E5UYeay<3FJUU$Puc0Bfb&9 z;MVM-6t8@5PaO>-zt`zvLcsX$X4F+v#<$^rdZ$6%jAzK|lHX~N*n9-<2XdS&Xvy2@ zhQhp^&Nc3TCqjOnhYGHJi&Vgq5Q!8X|DTg4Ah&`fVYByo*@uI;Vt7a{`j9x+)c#;F zSRcnp)~EOoy3^sWRpOzLH2=8d%1&L;-f%fs3siEqbW|?@4dSr8vi3^N^Hql zfgLp1yA^L}!%mv!T0Q&3Ub&D2X;Lj?@lJM9bns+W3~4)qXq|qxA%~b__-0ESq-_3 z-NwrThHUYLhtLaVy+n>F6WcT=u65Cu=>@4nITEaKXVYMR+Ccr7#LmxQ0Tm76g*{jx zhn7diY_0fh#;0O-oq&xn-T7Fr?hKhqc>5q|iP>A@IZO3e!}UsANYdD+63Hw8-VK+y|$QMmN{ z@IUCgfX2+f)_33)sQfl&5hPAqFEx}z#)VeIUZle(TRd3oyU0PR9>1_!ewq$u>N*qq zDF9w;13~%aO1!X7XP*@4)98@^qon8p^X=HcH|fYJrUvO^y~$M`$Tg1n<&qT-KZGF; zx3+)|%*(~I@W5RM;nv>+x8~*IceSi|c=^%=c;%tp;no-M*NhoPy`<=+W}(;(L4u8a z&(9>d=>{C=@`ej{KW!g{E&|e0?BStg+O8&b z#HNm<>I_b$7830ZCkV_GrPKa^t@#-+H=PD}NQ0@w8{$wXx=k`=f+Og);1snZ4=SY4 zRAdpHq63sRZf@0FuaWzSMy1r^6M6upYjZ;7x+h(Pk1&V-qYRUj-U$G93RZd6m$cpS$YHUh6`JjMg#aJnuEFU1oJJMxrf`Z*9wKTXzqPdqTH@BioN0JXa}2vfcz1v#e!WfR6>i%YL@MmC{&8zHDHzS$4kM2 z5sIcIkiab%{u;GctD^3*Ra2}qK(X)ld(O-}^XxvG1mxb|{k`wo&!^evdFIT_nKS2{ zIWu$S49%~;EB66(N&+<5@8rY2rbRvFIWhp&%h+0>Nzi55V3G!1SlHm=-An9J8!puz z4`=tcU$p1B#aB?79DNS$12!`#(J3iFi}6%%!USAq zp_GB5-lbF+-6*4h3%FdxCT6CMmX>yBFPdXz!y$=)%l?R=g9!*tbjo`tGv0ti$d)UO zcyZB9ZrBjK7a`Ii@hU<(miz-&&6KEUqzG=GFthTojt=H>F&%-d%A>}O9!)Z_mHEuG%=59A+c*(+I5z4GpY_vAqy}9gzxXZfmyPZFHr$f5+QkExePQvWNy;I87a1 zwT{aokgq%!jYMHQlxEP?mQ{CGw1R|?HhxCK)V$4oL%JL82^`wk1Nm`<8h#H90?_bX zGqAXnslwV>pi7HY{30B1ETJlU#k6J}u6n0tRX5^QZT?{x+vx|XXp1c4(#H1wa7g+W zjqQcpgu@W+@cjQZq_g_=edS%zkkumoB@|w?wzI}2n=Dk~40CC1?7rvcWTwJ%Q|_xRe+i}$CkE7Y zuTsSULHw`gj;lc6w6B>JRbjJrK4wOG_hv^EB0S~4gM;h{db$WLYh`Op6FW@{>pLQw zm_{qrogbmFLwYeK4pbmGt`M;Vj~X)tLafeG{a#ERp0|H$ms6&rI@Gu==`2pJ3B}Szg|=Gqh}+VG ztOR$;O?&C%CrqJ4# zTTaFL=K!G=M9s#;DA*daG=8b5Laxa;OO|w31n)PDS ztOuKBod`eIf$(!{k+0J%$#Gj}z%9we>NeJ;HrDNU4i0O*Y24IR-i$&yb^-N1TbQdAX6pR}O-=oY2WOHJ+x4@_5xcL4{@zU+5H@$} z(`0UBsje&EhG=NL>0|3Icn$XR6P({shJqVSs_C4DW>AEV{TL0laYyq92HQ$-DpGo- zu__^JsgEEb>R8jKDdNLa1l5DA0EbD02LmaG=~;%X%~tf{TmW zfCVwMsG&2xcPhTMreUjHIK#~h@vSIdW*AlE3>KwkKDR8Uu-V*|MbqcQ6`!!`QYIsc zG}UI%@3eBOdZ?HkH1`cr7IKWKz)_K{<+-I~YJBPx?;_x47a9;46+I$NE>wej92fw| z3>e>z>IsMP?LjDCq_#<+AS;(99Yw2=0)a?1Y^{ldqV~>r+^Y<~qOIarq$_yVfadM) zYk9LdgaCKAXKU)SHe2FLCW{*mvvQCD!(oGTf*T8M(cUnaZV+G{8QB4H!#i$RS0t{$ zU@HD4(gO%{l`YRVW1K`soKUhO`p~$+I-(C9vFkY35f$Hz?ufz;5TO9Eu|?1dbvF-z z2Q}zmDG{(XN7g>{E7h%ANgQq^mh!;Cd2|Wo+eiyo2xBNd3Z8FN`$=)UovUW%*jj|<^rHjcHmY>bXSX{sR&@bL4=NS67BatlU>=5LX?Pt4L zpNelr1ae1;EE<_D5`#?T{0n7UsbV+QIlwXoitnQDqYgyWM%0bH7BM^8Itwrp)+~q$vF+B zj%b%sZK`2iO?+Lz^W6Dm1b3Wz64ik-P?DkPm2y!a&!Ro#1Q3)5>g)!CWYCjPqF$ad zW#E&lYigY_72ap7i12A`pxc|Q^g;sc{^RJ6 zeNL2cJw_J@!Ph6DQu*- zIFIuab_<$Eh#{b|fZ%v+G36jFPeE|JSQ7V1n4YkP0r$p)LT0PT@)PNW_ZjI6a z$~vM!r!Y+nSz8E3U+ZDbSZZXM!QkC=f%V9`4j*#U@Fzr-BIe^LFP+ru=qK6dAtz7} z>8e(`>RS3-Bp9KzYp2CalWc`tQ7z&M+{0$e6iy{vXQ5rCN*D`MRCu;7BR84VWwbz@ zM-UavAE>7>n`rq6W)rjLor%LBjd*ky5iiC|b`}El>pX(QmloFH!QoJZ-_&8@SK;Bu z@;v+yRe0Bf)QQmUe>sNdG9Da{w=;m=Z}6%Iq_TL*u7R^d0d7Px_lj)k$WBqAngr+C zONdW%Z4mz8*=Obk&Gj%Eo~h(|=+p5ms-qtY`rKG{IL3c~W)PY%XZ|*D40SW+H~G!!?(g`@poH z(;wC~$3po_d=f@w-Re29`yR)E);$8j!$4$?@QK@{S|)9@>{JRxLIr6GME*`_4~D0P zRZgS;D5ncx9f}c-`|LgrFa*QvD2v^|K_qA(s~82WnC0ZQ&jF%Fl7 z!nwSa&4A&o;kpY7^(*!YJzG|hXy&-C9t_utLR?+3@E7B>HxN3J8dx?raQ`CAl<*%j zd}n22REUD^P!i%12C_XCvTaGT5e1r7i2C4i7}Ek(wGQHpexX_5$(@ef^3|%zSn_dp zrLAXfd4G7_!|c;@R5Fb%k_CHa&k`eA7BVs#m68Q4s{HQA@-oDqm!Sc#&&lhVII)L? zC9YAvh!5Fsd{L!9v2p4vcQ6`iv~zcSy>NMay;VZ7q=aRV0Ry(y-AgBv$5ufNEbB^J&3W_!=f%wS8B3}Z;s_HnMAe~zy*a(9aE4LQN*j@4lPdX z>ac=jZx<;@C~bhkTxkLca&MCJ%XB#8EmTl(&~b9yTc&fw$xP=!D54g;5kvC^9oMqv z08x*#s4TC&6om+MH68>|E}$?4!-2297YS1O2v=Wu4?>eu>NJC1Q%C|}rl;2w;^v2D zAc{I_;?1!errIjyx{D)iPS&Z}80x&Kb2podH(nrHnPk)22`h*yeg;*9DIP$*t{k*a z=9%h&X5QqS-IBwVaHJ`oCYU)7pC{Vq+;K-ac5}dYrwB~#8^n4iMwY5_~|&)}COr{~$i8 zlU(H7qJ^C-3#ZCtnQ?OuXOGC*>6jC+qgNNZwiBz%*a75W&7T>K*Lv)h`E7d5@AbOb%G45;sUxL}v6#^fxys z_C?o`)cG4*ov>R8<;6HMWjZ9jnFisC@ghOy-an%#crVW&jFmVWUAhQDG3JM7Q5A?s z&lc4YB{*fFgu^5&q(=OMs`X~kN# z?P;?QjBZTz)h!!-l$f+Ug`9iZX+O(nXg;dI+Vn9g3Avw^zjQ4&)6Q7(Zz#kP7b=yz ze0ICSMEIADKX2Kh3?PM*2-_-C?XaLFhzV6Wu#}&SRA@GhUx6f8Qk;hxwPf&*UP7Q7 zn1i7*6huVzTY!wI{tI69v|fw`5xX_Ci6V+cKi7h#s*Q<$bi7SZa!J&E&eA1;eA1@9 zkcw~0pPydECTQEh*`oIYSe&!Mi@3;RMo|wgunX!O43-=cK%!K>5K~ss?yArSu{>E* z?hT$gG4;haEjeHJy*HKWPbH$^fY7v2dpv@OWPU@$LqDOjwN`&`fK7^PQ@%#G3)8Wj zwK3p<`bX$TU8(A0f#RY-JkXRVWObFwASznMZFqb0-%<_H`EN#<2YX zw4FsQ;WnYf@~=xjs9hk1V=$SA+NnL)`9_(R1WD#{4(K%)Xfu&%nPsM%OcMcLdYC9gxG7ZaWU&mKrAWox} z;w5|1xk^(@Fr>*l0n$B%NY8xjKn>6GSM&QP{(=u2#xLT7&ia0f zr|hi@EV_<*e8{Cx@~}n+N)@hz$=I$p;NBhh4xxxe)Zw zWpt`0y|(l$BnEO8C1mPTP>;hkR$;S1@ZJjtDDO=>Pz3%vED9SfeOP07OqVN+BRZp7Hb{s$IZ7BHWITChaHHBRxs3`@^mASvww@*3wgXr5Wmbn^vW9|D~Q0Aqb* zSW0NPP8!}s3_nJE7t(+~GoGVKKs9i&FkLTUj8w}5(Zr#B=56^7~{ z8-U!>*I(UGIg3!)M9-+~FT<$uhh5Zt9tjN7fKaNDJNZT4RZA81YH_XfDr5n}&Jckn zt2JnD@(d*%^s0GGlgq~TE~%q+Q07rmYYwJIC=%G*lodr8o4*{{#Px5xiJTeg2$D%M zxAT{NxiW_qlZS3K7YI_Quu~` zIe`#U?et($$7Md+rG{tW+9Z`gh%VWebfhv|AWz-djr-_)A@?bx5{fx?Ey;oPj=7mS z$Tp|3K};n&N1K5qjnE&{SA2Bx!v0F~}rChY--}nDL~VFv4Xq%Lplntq8hI zfXcyKrn(*)Za(%@sE^OeaJ?Mw^*F$L^oA=Dq)%2V0X~J7iLNKZtLt4zMOZTyn6tsM z{)_j%BH#mk!E}(Yv`y6V|?Vq@C?pM$HR!Mx*TMPtluRn16BzWIWn>ga@fEdSB)lP15aGEFs7)B zif7FXlAXOoO(zS~(lNZvY6{Q$L8RFqxeaj5FVryQKoGVEd6k@WBVq>wDe|BhJMZPA z$KGM?hYbydoXHRh#9(9Ul((Fk>m8^1ZR&ejJ1g>u?i-r2R2|sD?NYO$RYbLecaPb+ z5@||X)15^EKPgj8_nF54I~*3Cd4&1>0DlWZ>>Z4c+5dtSq1(934t$KYK9v+~YTOKO z@dg}R&?bTwqHOktLkbw5huwOb8hdoHMRu$v5>~XG+FR4nfxI!z=|317@**pXj!V$P zvh%stOg!UjgQcsrx^(r}SY5hW%NgHV6e7ZLq;Mkt8r*8rNBA8PGJSef$x0J&n^sRM zxkfrevImoR#V>kLF95X`T!bo&7|~gq8PVS$+k~j%ih`KThv$Tqp$J=0_EP}hHKYwi zQ&vEo>dMadl2r4tFE=Jb`%MEp+7Zb0Kv4?|1}c{=dWdqvKkIgK(XqG6#lC1DaInio z>OLMq`8Hw}CV`=D1T|?;70|v^H;M21aukj!%Lp=tyEbos;ARj_y+PyTDEM@lat&u= zvyXD1`UHlPTR8fLOczDO4CrzG%+hxN!wM!!m*cI_#kr=V;6e2lE2JX=J`I=P%We`67x#kE`%xod_nXo=Q}5n-^f)!FJpE$A;U zPUM^A=59e}LYuQ3`N)UdeEBH!3RDd-*9Z`h1K~ORn(GBc!`Pi!dzM7r!&Ea}0CIMQ zkrMtJiceP4T9G1Ldn0{!VlYyGD5%;-BtYx_UsiVqlhto96z8aRwD zyV!OT{E}posHVZ~5hd!BwbVPGYZ-9R2<geEpVs_)Tl3Ye@U6;^Y8@n`>2+Iq^*MH_`*c5rKVlVI zk6ZoFG*BIE$RsAA(fZv@RFddxOe8D6{84NORbVf6XF9$!zqA#fuBsw6lUbD9o$SZo zM@I_iV*Nga4eOS;%OE%QB)0&hjIr@6k3nI$$`|i-8Trgn;P&Zn`LBE9Rrbk$N(>lr ztt@-lv2X1%f#_0=S)A_Jg3}#1SHtaS#6*3l8b4cN50y>VMQv;>^{3#;mpb63#+pBiYMT}fOvs&vhwB=*=TN`afS0@Mi-vt|egf~;HSS!_&z!&X;w8lw zc3Wra*@HLW1H+cP)LUHY!M!7ydb^)0mNfJc}hg0m7N%ng5I7e;; z$tbCGrBC*OkMY`vgGLu@th==Hp1bcpqHaTWLS1S@s&~V{L8+fl>P`*dP*l2pYl==G z_%BO%@vTjbTg#TfQ+%t5xLVV&UDXfnM>@t2QwjsZxSgIfQf95<**0KZGY6Uwu{FP; zRnUOGu3W~8(s_CV$5QyTCHD(piQ`gK@bN6P0~WXY(xX!G?Wt!{8z;S#dNuXZ!@&G* ztOvbRx8aou8(!HBhUSWlWDDY@28e7Jp@``0`>gr_;EU3sDOKA$$ZNO#n z^Q$OUt)&G?(BfdQ^2Lzyw?fiUBqRe)Na`-=t-JKO8xNiHP3qP1jj3lhyuRBllb%gI zm1^iu*Y~HM+VK0`Cp{I2(5cZPbc7L!#jx)KJ{IjkmDCvs$dgV$_K2-KbSMD;Uwko5rPPLJUl&_x(uPzI?UVX!s%OKN-O78^P|7wn zX3Lg*8HbP~45j1!7DEc;ctAjdwRT8}GMRqdsx)aDsPIgtK4gja|0rcIj)Os1DaZUO`bL#dSU#5`kr3M?wuk|;~c%MnObM2IzQ&*- z2AOX|p9;&sSslb43lm;|0f%}4Ybb8z$Sc*C!)&H~{r!;brA%Uc;m-`h&~m8_>kL=X zdQ3gISbkP<7Y|`*&%@7LJ-C6R(ewCG{J(*thLUZUnM+-=v(9&g2hc?0FW-jeHV0%6 zMgMKij$a^Qya8H`=g_QbPU@w(ss6ehI2K`c8^t5~C+r9zJhsMvwv%{wXMc#Wa2hR; zxQ9S)Ga%Os2=-xaDqHe?%pKV}1Sx>~tDY(0^NKuo7wHyYQ!La9Udy&*FE4d{z6x(7 z4q?}K$6J6Gth$>JVnR<5zky z6YAvUXReSU3fyW6Y4Hmw4Zg^L&-cMiolq`ixqI*jZBx>K&4~=G^s*e|3^g7GQrsT?S`1WR5SVY+A4mkzEa*$SoQfYL1;ln68ES zM0=@oBupT*g6t2GbW@SAN2j{LGc<;4uFZ|sO<_j-AAK_FmN4qKvSgX^^Yc{uIsSw$ z^u&_AT)>E^_4*m0jGYd}k{`mGt-yX=dbNE@d9i^prP~E14Xl!D!rpajt`UFrlEoi^YpD-n%?F4rFbI)m$hNm2 zx0|Kw(gypKIC+p(#gdPb3x`X@#|;g3BTF1Spq#RFFTTCkye)y}QR)6__-`O0CK{+x zM0js=#TosvasGeB}Y&9M}f*bf7d0z(h_tq)S2xOkVhq` z!L=looTbu=!Cc!cghZRWMAj0HkckC~e_@-Her!40#Fhv2J>Jom=|W$&S*(M#Y@k%i zCSk$|2+CKvW!$C5+o!}a=nJFW%6)Q8b(DWbNU7u>Q?V_7p_jwBvoIKz)G($*5t>_B z04F@y4DFRrHC#N=UfCwSavv-)?TcnS4O3)S%F5CIxX50HGniEFDzfL9xBm-7mP{6i ztn|$PdqsAMjF_rK|A$02pf5#M>HGf`kqvKjUf0F>M&Z%i1`YalRf)T)F!!Kk3)_M} zX423Ot0#K;(H&odI%pNG4jJH?etg7?;VXX-1AKN0<81-R7Y)c+2ISykkU9f0O+ji8 z&ceim-MWSfJ---5w#p2UpJ+4Z&%vh__leeW{v>0(64V~Y)uyS5yN1SU{!nCuS&Y3E zmL+EK7<`%{pJ3vyc@Ln{@ioT8UE`U!_xuee?t?GG#QhqIvN&1$R?$)OH1+IAXx#X6 z3=M%*DaNVH+UyviLEkvUl;QvAW|SXc#xAm-12eW#>ks$D?to)YZ2KKO3zyIt5fs8y zN-<^d5rl*zb@ZDgcHoPUgR=w~KJ)v*qg35ikbvp6nUtrny59w8p%kGzrEdV;q0mSO zLw5q&HSW&88a2-QPDkHj-eS!OQ5?p@AeJPP*=&|fOK01s#789>#b(xA)3DiYlf{yH zK6SI3=G%h@j03p2JpX)&Z071FA~^zK(Sq#wP|@SQaQFvO6KU3Hfj^NGnlBV#dXmF* zR*5RF6ZU!`s0ukcrC<~W5|+nb5R?)A3UN0ITbigdRgOr1#=O}#-k&DL_4 zE4_KvO}7cfvc#&rvtq%e*jv-q*SmgBoNl^gF_%ox9o1FvW#~mQ;&C(;{+sN>@+Y9w zxKco}^ox<@@|k@A>B@c~^mk#zQ3T54o0@=f?qpGl5S_>td{rhkBH1I-XnBbiIQEEc z$2q3=-a$L0j~An9vLUAJQ2JZW`Bp)L=%g+9aI*~!m413*(0=+Zdd~1A=M*J+6bZ4$oi zE7>ye*`Qp-mh}wZuCD55*hWRac z4uZV8u)4T_3`Bzdt?x;X#GW>k{0o%f{Aci~(|wWw_>=h5&QBaiUy${usrXdwK4F4i zmOuEX%&!I3Y>U-z!{Y?T?B#0G3s@*BOV_`Ud{S1EUhsz66SEjzmwa<#cDMGQE zFqLHyf{VO8Ig+#B4)BSagT-#;gjbxSoJNcPeB?IHt9il<@PZ}BFjc>A4RVpDdE}CgVKxcHT46iGMZ|am1sLMII0bRknfag zC6uZJfI$d@c2-!4wOxyS7M^@43S*_FfMsBuNqeL(ea6SpId&YfI(=+9jNnSucK zh$>HjdAaSY_ac7yk5qEJu9bjuJT;yLNaY8R%%m-vUG26GvD-3>%ki;;!|qPX?2y-; zQ&mJ=cfOvT>Tc)8+8L2!i2Y(;ljYH%^n$qrtEjdieJCJ~eMemJe&tj?qb&<~v1$m10N!*8$3UoW6_hO z$Ozv@fK;sLabKum0EVyDqvla?YdlN5Dq<_Q0WaNoRR2NrW0u>V&Z7pNViDV(4{CGX zR^_PG!uxIm4qx{%gmNfXu-WP5a*i=xLqoZO4NotZ`B=KHVAIpfWj=;-K?MXGptph5 zbH9iD3yrJs7aV};QYt=>PC#Gb)swtIoypFOa3(te{X-&Rp&#P_;*yC|nIMR@efvq# zYrtnL=lhJG?+ow$7x|C@!9L;Sl?SN_ugb^GeW63_roY+cAFF)s93szXXlRIXhMsAwO^q*?Em@XscsYWx&vNWbiU~uDh?~#isNt;0PNw%OAb8x*$|Q}D56cmX z`c|?&8rU?jTWsY_V2+J`+40{3-UMmINz!M1-%0Y>SLh?To8;Q*YJYdI1JaKDi<)dw zjC)GpbXnYRzYMSKQhFdeVU&%BrYSvuiYh&v8c=q3=K$~r^8aS=f05T1ILU17qXW!Z z1DcA@c59#F0S1eL!e48r^%By&^0Jb%yrdJI$J4sEF^IB5sr-+EB&vQ2MPV z{mYVmTX&pGl8~b{*h-(B>Mla*iw6D#zyqZA-~p^zVdr}_jgK5Rq3;r@j`Q8fHF zlj{^812RI0k~0j{B)@DJ+p8;3Z2oc-tlg$t|Ep!{^;vw?{WSAc);jHef8Y=R-qFR- z)tq~k+V2M&0tz#<)w&qE8ePNv{?*Mfer_lwjjZZ3`woWw!+1=BBz^3k+?lf4?>NJscaSD8!mim-W|}`NR*p@ z-=s@k&FJ2y#@mqNc4e|s$i|XKqi~CG?3Q*8ZVNR-vLe)06Da@_sz3g@{)5i;nsDi~0 zw(*F9u)QfB4Y&@Zv8`;$QH7-jh}%-DIX8CLhl>xOiKBXjqkP0S{x)Y=5*+YLVr!M; zrdaYDIPd2=DAmx_)Yyd+MfQphhBNhD3~=2+1FC(FR{*6Oq<3%|LGhI46zQFYYTy-e zx`@gjw9oTpC~@%?aW^166aQ{yJDi+79YV#PJ+Vi6w0veJ-%vH_@47Cr8>Y{Mql;J!zK ziEDnA5+o=m;3}5G9t_A^%nZC`MpsZf>{Pcyd=Y5E3ft{gSb#xP$nN^MX%U<==#Z(> z^7v5Fa;Z3Vm2{GcC2?vcBrwIC!OMc6ii)Wj%_N1?T#EGxt^b%*V^qz>jl9c9NXm~#xzC9dMPI^Melr3&d z`K`~-Md2%65sxVwq1F=eNLf?{HzA5YB7K_^*RZyPDQWC_OleIA>}&)+HFTN7ZYZt; zaDgyz<$-K%FqFD%vsCm%rkeJG-hz%pRokWz}c2X!+_mVmy3sA+Sl)zdk zC~-X`3ySLvVTeTtSNox%Wb8d+g{TmRM1=|=P#B^fWEc{nK_P_uxTKIKPWA=C<6|ob zgSY{bsJ>dphD}3H<|N9b*g$)y>bpW7Y+NZ3CHw zOCoN(QfD<>D(^f;N5jI0_L7042g;zVCgJ&&3PruK7581}P~q`HlmID3tw}=NI2bP( zlgsMbC|f&Z0Z^an2xIkW74)rWU~zCQPOqT84O;*nkZ%FJVQofu!74?;gyanPa#{s= zly7d3BvQ3UlCXH-t#W^C1u_P8$5P&WV%t3Vc`+gQ06NH zI9I3zYPIF=vY^zJnFkp&JcD~OYkW`R|D7CBOq(iW6GFz!9lXjhba|E$`0d+-9!EqB ziO}IC$CzS%sM-|bhqwOIye_$Duz>^vrW-0E2h506!wca7Q|w#vLUb4lUSFtNyt5a$ zYZr`f*Ckk2YR9@#8$v!{-Kf457kakfLeJ$G&z76DBq;89hqxUTo+#;#uZ51`;MyLt zP91e$beK8RxC?D-`3`Y{i4cEmS3*-niB@;c~V>akb*e(v$b5#$z!XVUQ@cVvQ}1M zrWX5}k>I+vvQ`#f#vs>t=1O28Wi1`eu%>4gQr3D4DGO0|_S~OhA>|)pV{28h=0EFO z7}0|aqN9OmD!$HEv222(Si)^8LZJS0XAa%AxD_BkM$@K?terL)BUls1fX!o zuQNa^4A8&HnC9F{a6{s#y=tWVr~F7$#)F0K|e4KD-+b1zJO^+fUAq@u|6 z8(}Z{toV>hEmqP8ha)UGTbC-*%-H>(F`g{4!Yw50QRgJFfvMQUrHV5FAy^M}Sf|Tm z>|UW4-EqKV<#Ba*xkU+gVqpua3M-&XlT0JCS?Fe*jm3fY2kT_b(6p-AxB zD@rYp$5#+=c=H&rm~v-9{!L%F#zj+ZOTc{|q{n@O(9iOp%UIOTX!?o!6@ycYADr+A zB?TM_=Qv!pQuH~cXjnI{eoPhU;)hg$jtuKYcqf!%(teCH zuK&;qWl|xaC?Cx7Lo8K*F-;n5PO0e**?fVqGUJ;iM5Yl0hUW?u5uz$-ZWz+5UDugV zu)0cg3RUmM1fK;dClOH%I-qp53WcA7bemqI>mI)yI*q@7WwcU72jEx|ezeL6kxKs+=rTiMr;{t7bwQ0H zI#4|eFZk-YfEU!U2Y#rjgeWen_<^Eh2;Xy7)YM?En;t{Zw;J)H+5hx847acaFbcikL4&w1FziLlcAZO?r)_5504IjDa5s__w=ryd6hJ z*_@}>7UY%bL#dtPyG*W|HJ5B>7jG8wSSriD+(1R|94|0XCl_MCsYc12 z;HVHK%MH}u?()-_#bKud==A1T?Lf*dv--9>iqbd)oiI<=c*pP2t@@4AkQ^#OBN5d zSaq5yVAMNb@#TDFB8DAz@Y~k6chP1kqdEE&MQvNTKJ$*5ydU|7v#rVN;kmXJtXqZ` z`ATk@!B5mRgJsCHQMW#LFxqbReuD#0!M0nly$2#-o>-V3V8HaTMHmM8xz=69ZM&i} z3=D1;39yv&xeGW}$hy#tFf_4|fb~xkII*KjQ75)hh-(#=jc;{!qbm1Q!L4T@59m+r6CPYs8 zhucqbjj-?!181rRV$4;yrW~b#mU*rb5gP!p;6j%KE{mzYTdy=N+CSfaosO)d?$nWWs~cGpGT(OlYr2Ex@0a{g zmQ(```Cb$ijI5RB?SEcFVr+?Y7BTlv3qzI~`zj*cko34r$(>-MvOG@rcHnf}udXm| z6IyYxTgBKRw)v{K%@-Q-ygK|LPj>k{m8JJj!%ZyK%=LU7c!TDLx4${CR#%?%08f4x z0d^u`y&SyQJMZcaxTw`zp;n#f7ddTwEabFNJ^J?heU7`)ye;{nwSuEOGvN0qX732k z@gQ=;DZ+n)$`{$8I^>iG+!DTz*=kRCQ?aYY--O;CL335Obc>>Nze_AvtXypzBJJ$r zkzni)`-oKKVV3ji@L5jv_X4r9I7)gfcN3dWR~R4>eQwK=2SMsp&zHI>8UbWubq`h?yiJ`>VQs7t(r zR7uynYXoA+oOD14V>0#-UP5;dnM>?~!Q^aE&!CEaZ@V|bZwQU7FXb6T>%P!42nPKg zWIv>E4Heo8@gIKZD~Bu1+pv{G1nGzD7>60o!H9B@NymM@PP10KuOk+L`)FHP4Nd(J zXy~xEPz~LFZ%ANDj!g7XlKdrI1xlnFF7v0X^ik>x`zZCujTQF1uAV~5J1 zNSq!~b&-<~j5e_M2hV5N?H&6iamK(Jf*Au$EEBGamS7cU1Yo)7X-CnNK>U)xbi7#u zOc&Tdv3q=`D>rY$wt?PhUxD%bu3}g@=;52ec%|1!3%wxV{NN6%;Vd#bg)2mT+;ey5 zFXeQRcZ_xfLVxDYfxR6>AVmi3izg)I1hK^9=5$*!qeW8Xm+@5Ub9a$gdc1Z(>%uv3 zt{v9IaSq(BC%lFaHoCiPUbBFTr&vO(DS@Y12d+E^a86kZ=M*@p)VIMoWi^~rsPo#5b4nkc`vT{bXX|2fdU!daoMEbFPhQJ_ zJ#F0B&DsZ6x|&~b_Eit??tu8B6(Se6w5-OiMco2!41-b zz&&*vHw;v6*ivbClbajC7uYW7j=zkDGDPBkrF_FHm9taN0eI!Pl9(mI8V71|Qnwa_ zOEvC{!(-&o)El)a31D2C+PLFavs2GYYiIBH`|O(6V>iT*HGe=YqJR(Z_+vcvn4i1? zQIWt%Tg9hgDKKnkO^_12OpVWf{i4>p8>dXZ&rrs{o#-~G&tC-9UOGlp}8;u7jyHE~SO z0n`-VQl6Wy!(Kymdhhavt+nMiQoIrSmC5IpROYIg))aqvLT##dwp_!2kGHGJV(-wK zq?re2xTAu@%EKf1bB3m`3dySnC;7G^NG?|a00(yN{{&4GO1(~(cXw}bZv@2mJ0L=@FSTfnY?C4`S z;!M2LbGJHr4R#;;S7Z0#F{ddY#5RV%U?Fejy#8%~(jX?8nXi8jd9OVXnzAl-Z70rY z(klg+p-)=Vd&{kph=0}{?*ogK)z&QPvtBl_KGOf? z9$*b4cSgK#$tiNvr}#G(NL*b&_{&5Z%fSjQ7Pda<_d%lLJQ< z4o4%=OB`r99Q9mrt&(|i9Q_F+yO>@!v(9EVgGzQaU~M6|9)&Jw6)2OzIF-RXB{O>5 z9VBvhcK@G(NoeW?wQsZzRDSHSl>qT-!Q`MGTg#gfiUnR0ReK<}(7eZk;q+YyxWS}W z`Kg5^=u$LGkxBgK^4v9HmQPr5!b$a1wZxV!U`rwW^7bp?o_ie=l!f-j!H>D*n$&y^f3dGHvV!UN4=Nr|#_ge+*V? z>YC653CrCExu?>q%Ura@gg!L-Yq)_A5-GQcYLJ_9Hjf52#$Tb|sxtAlN- zn*DaSp=PpKf*K9_?%0*r0AaCrU_yagsgxGM{U-%5N;3{5s zgb!hfVGJE0|h4@$kKCH??}ko1Ln(;k6>{ip!K zi7EC_ZRP!1cd25R>?7_@Sha3?WkO5C-LZ!n?ru4~@_zC6Y`?CtCx_y7NWcs1YkkoX zp?N%rcU|MA<@{`}quZ3?i?~{)*9i+jP61D&|Lgo1$Jo`C+@ol_AY22YDlRNtS^oLFQSA+D< zk&pQhw;G7^Ntt1xgs61Z6MHl$l(v?{Da@xO4*Ac^sHg$;-iYaS1I zhn{%&_)o@?Wh#puRtL13Z1aL_lqi>ey-A-Eq^m?Zh=m4XuaXca8HlYLgaZUMkxEy_ z5eDL^k`SW|M0-hySH7hL_?iy^xs5en1P64>5cBaYw5X3I>+$Tj^)^#NZBRmp7T22e zLxc1JS}ZUSyOo6an1R^RS&9}18i=2kg!m`cW7yTVm4x_>fmrH82rcGgN5|5l9?xjM zW1+iEu39hGA#rf|;4E~J$u>I379!gxP5NJcR;tN|8;Jib39+YvxT_?@pRq$F{9h8H z+dy1Y65>t+ae@yaWcvVyE=#t3@N8LV6rOz+nr})d4@wBpVunfo-A_x=Vm|}%vyu>R z-l#48PDzMg8;Gxzgm}b2%r6OXtAY5a4-U+o zKRzmLPd)=xBm>kTuv)OR+B7h08C4-Zm*wuqUt7udsk4efR(c>`C5Xq$fB2@-=xV7e zafOe^4JPdzgU5-;D|j4Mr*WJLP&v%2hn|MfP*kiI;q7RFk4?R)F~6QIPlN{7eN5WV zB`uchK;H1M{R4bK$+Pg2gLM!p`K@ngJHMeNPxagR2a}f2w9iSY@Zyz{@}IU3C;6B@ zVDijXY=Ti_$svBx83XoyEgDAwrPnZ1HfqsW zo@{dN8JY7=FXycVImeouPd}`3@fD<74$!(T^>Ux1xt-Gf^$kjw8zeU(UwKshzDfJC zra1%l1(<6%U8|+a^PXC&Yt7e9&Kkuj;DcE6W*I>gvEG6aw$ih-XVe#0!ysv@Tp=bNmD23bi2mwvoS zuL#nW2oB-^1M&NH1w?QV|4eBEI(-PD=ahHvaw_i|ME3Q$N#)&@@u(@|8Yv?f#1y*0 z%Q>eY=hsZmPiXDQNl3Rtk>-A%m-{`M+YLqYOzsM;_oF^-jx}l79|bL!xq7U*OGLMK z0-M!QAi9+%+x?+zMFUD-i&E`+1xsG;6?suXk?RcXf>4oIHHbA=SqZ>I`6$iiBw(4z zc6g92Bmw7}^gV<00tuLHApZD3K!Wfz_+SI^SV@R-195vvh~Ir(NwKUX#0CR#jt?Q) z;5g9++R;bh86D_4H)C=g?&UH{)F}>-tx$2)nQZ;{yGDn|c7#dq4blt9Hp)Q!M@fiR zzNSrHQ4-=Q1F^6q#N7s>t|Y|u2I4Ru!YB?QnVd0|trslY$nMC#_~pVaIt{cOcQ#AN zOq(x1Gha($6ZrJcV_!)2Yw{NZ;y8u)s6tG|PxhDqqPBIeZi3@lMeYG%(_}d|Nn7gD z*jdNIukL(J*p(Q+D^Xpa+F&+Lce@DHVz*1{!8TXcJ0prbv#>i4XPE?!qgGdDQ70V> zw(#ZGcwvB}ElUsN>n8h}ka$N=8_(zAT|f_dpRk5a2EKPahZVb6DBj{v~IO^#$R zuf&u_#or=(7b03^5Z!U5Ai6h8+tbw5pSvI`i^a7|v%Hs80E@FgOt$ans62O?_O*J| zw4-XxvXjhGh*`p9IY+Yy3DHHYVpA0Si3a{dUKRDO3aq#mS25OPc_ZO^sqzhclUni! zX;sjxe{9lTddh=;)xp;k!9Qf+zwN<4<={u+T%Xd66zpfE^c0Kt>J=BkQReHmQo3*_ zHiL@dPHdiIt4qlhsECF=4{vZTsgs|~ET*O9&G?CR0a5LhYV$Bl9O9ByMvwUv(mOAdlyK>};WcY3XTDQ|3M3t#YAu?0TfgWjr zz4KG0KJJ}=Ql7fAA86waFpH4L4N1~CUD1kY;Anz=HOV~2uE}Gep5#gVNdziLY*^!e z^@`TelXQ(44-!}On)2)X>g8TI3F6vOhEp3H z4Tzd^G$1(MeaD4>h7OW0821va2i;Ue$V?ng2m^2i8L^xl*PZPKJLF)}b6*y@im;d( z#=^B{IEaLRi_j_WnS)!~Go!CvMogXn7caq6_E_aliV>-{DVCWHomEH*R!?!Dd_gQL zAe&>b(^x>T0;tMc(dclum`+F<#}ln}G9n9!#}Njyi6~R)9`r+G+g*PZkPw#`g-K|- zr?*fN#2ZSZ=w}3`*s&f-voVRVQ_$5&fs4GzcDrl%m} zUadr7w0hyMLS^yok%%(j@e=-2k2uIMNkaWWXQ%yvCY_z2sX;Omq6fv&n`wa=4&{Jj zQRUDMJJ`; zOsZH@V+806p{Z5S4rrD9xuHZe3>CE4ea(M31Z^l$9S0Fl?Q}^bhf`Z}x=X_H$&u{e zybgCGxX4`8XPk{}EIwFb=UGb(evVq6v{HO>SD z;Sd&A?v`Ka)wap&i%q64{{0(XUzjSUqtwPi3jd`+DSQhmA%)AOUDX$n!oN2Z?jkL+ zf`!UR2x&BhXYLosQIOTd+{2CPn$1IN&W;b5iCyLKD2pQ-iQehasuQ%rgcfc>-{k1h zZ?9Mkj@Bf`kxrzZQXbdrZ7M;?c7N#B(13*E9)$m0;N!AIt^eWbx9)$?5W#*M&)mVQpTY*wa65VulT7Xf4IMKnm(s(G+=`7Z~+bHNvfuQ9q z56CI?nw*@?tid-y%6#Ji6oJ2rRYP)XHhjdGgeq zodGe^dZ?(x*f=>e_9$1iKP!mOVjCn`DlJSCclJ7nS6!W&EoNcn7s8%I)7WY=M$h1ty$Bhzo4IR5-{qTiieIe=3H zSPc)jzX&7D9Yd9r?ttN=V`q(Zf(B=eAH!3&4A_*YjMEafgxu6i)!aHXVCCiLB;h(_ zo{Otavw3*3b^k=02RQ>y??r{V#wf*-phM&-;mcLyD_p4!L`~FEhy;pDCoJF zu|aPX^%M`{$bARkV76r8NGPE{eyOZ%_PjGe;vX%hS(usmJieTH2Kl%?g~6ZH??6)a zqHC3h)2ld-w&5un+^SPzvL(4vpb8gyaJ4~#ypIHP7z0YzO45nx7MEaUB~q^06@!ZXSP%{MQS5cOFOwu{Lc6;z zBkd^u{|1`z_hx)KVN~GZjY_rm?GG z=|j1%Vo8Q8MJeqKBt$7aNo;^sIe$;Z`T{#NGx`C%YQMgKr)&n@sgsH#A$U?1lrI~~ z?{yCO;jks!F$j^}I95_%MEj;2*;w)(_?HMQtipVT?fcy#v=7gxV%mWAy&tdIzU_F* z{_rb?_VG0{;_G6WC2la+wGwGvS*l?Z*P+}g=z2nFU?2_1E#p~axSD+fP#36s4Uetz z+~g{&mE-{R-+&Me)1s0YXFzSr7EU+7+6^uEQ~3-sU}1kFtWT)5>dK$W``J8BHGku) zFai8_&=0~2-9vnd*>r}VlURO|mN7;;ld-kNNr$17dge3qtZg@v46tl5p7 zalF_WuG(Tam24vs#mT0aD#*9AwJx(t5XmU6IBB+Ur0_nq^&b~P*kO1G|If{gJ^=4r zjY#28;Iy(Y;3YHjFZh;yA8Z$h`8+YVSN?=!y0<tdI6X79OiCzf*BfWJ@_ zN9@+5lE;&{0w0V(gJ3S8a}hoQqROnWaj&_Qh>4B;Xp^1bfs3$Y_KLwIyktiH5(83r z5bHZ_II^0XiPA6+ELzC&CrmxqD5*<5T1TaudT^HfteP%AnJM_eglVGuWG3)qFkxDa z=hY8`G_p}6bDanfLMvv6 z2pzh!BR>ocvkQUT8oy!`#^e7MZZJHWalr4Ebva(TJFyq{c zE#vbV9&B@OOtDbdELp)bK9AvB5ne5((#5Eh2Y|TAjFXvhGzBEzm77E@7jLooi;(_~ z$v>qyKMzCaa!L=yMbApJ?6;Wqw5Dkbg0!7XyI<4TVd=6B*@M8?;7oa|iMMMcd%0u2 zN|AjNnexjzfGsu_+GF+ccIKd~FYdQ6Fjx)UmH(_coo&ct4``#C1Hjh^c#J7*4GLQ$ zg`qpl>=kOSx#?9sE(P7g7Hvl!K5_jrmb_2U&j=HySCQ&DkiBX zeugEbvh4LY?A-OpEXnsM8(Noskd%RnBk@djE|)FbZQ&jm?~eF9R_8GEai_&fel@;9 z^7p(L<$eEg*9gO3u~1ZbP-`a$cM>}Hg7o!WtYX5$5!4YbmeRMJ1pv!9dCjp z2#y)>!G>mp?mW%o!6vr z@HW172DTJ=TLVdGxqfZzJ6zEgu7{y6S`1@_Vj>#O@=98@pNjj!@`c!$6(ynl3+?DfppTAU~N2{D{3e zGvasRIq=`GOQe5OvjBP?RMbB0vhDC3KqJl5N(uR0jbQ;&y`HSr(kDJ5?{O)sdX)EMs=Joi=UbCF4 zqHCVCsTy`K6jbK+G7yB@R&1wezxZk_{vNF#icN8K;NcvjB*b)jS7Z<)2Q3o3s}_z_ zoH2FCpnaHAOu)9^tkW>BXv8~J6qh$soLj6Q0Wvce;V1jZxd!7*{Th_^T`6q@WZ$C# z#~ZYF8sJY;D)d0w|DB~sdADhKEi7;8vIq*?QA~lGhG-u&_0TkuZp*}P5~O8fHH(W1 zE6x!Dm@YgOB-nU%S()t1S|jUnfPe&F#ZR_lfhB=sf{}jnInaU$js>j81mBPn#!Zx; zX_5zjS)1#bM zgSindOT!=&td4Vg#4D9Ag~e!iJ{D!e>wi^)9-qUK)blN*13m=8QC7x%iW(@^{OtaC z_XO6{0jhab2Ydv&zl09RBp?Z@Fi`F&01j6NTs))>;4TiuKWY~zPBj1{N>sqzpJB7O zf72#U-Pz@57-jJFp_IWHqx3mPX10k}JbfF(9c0Oa8sw9!`xU&MPzA$)~IfPWW$vUg*0D_Bz@=$JH!PB<7@ zJe_bo3lg2s;uU$ZF5`u@;tz@mff+SbPXZFs@pDrhQ3%W-h`{_S~f&KSb(<&+a>jUMLmq{%z`o z$YS2MUKkI;Q7^nT$LNLO*#`T4q@-R5+XkPXI()sba7eviZ3C(v8HAre7A)EiVJI}i zABc^-5C)JK3QZ!a;$$JkY)JJ)4&O9C9M6Oeig_4GwxV2*V?KE%d2ZZmtSvK*z9-IrOt~6lIbHDElyvK7ZcI-QFy#(AJw5m zuaCYb^^7}Cex}_cKQnK}Pd0U>*T_hzZW&iXs$Q$;7JN;6~l zpXL?lgjE27PWS@W)Sr$%^nwrYg`D6#Btu7P{Xz}1#m zc6js@E$1AWJwJZHZ7_EINT}6ySeOe?5DI{`<}J- zbjI0*93HNXZxfsr(#0q5b^u#|{keDNX_lkUW zVFXFm7L$bgBpyjZYfElA!L_B`Jg7l+g>gmo%{0*!FV;DV7}MrG_!3&Sd=4K#lmEm| zwjATgFm%N-zD?1CEA6@MI_4YBQzlDZ;nL-YV}xHiOp+w#O8tXM*}>E#$5KQWyr|_p&+;C>c<4rm1F@`C zhzG7&uHZPYQ}<@SDZlTq&x)6oR-sf+()*>Zao?4n zX@8QRnJ?of`_e^Tb0a1FcNHZh{r|=#i%U;npLb_Zou^pus<4J(;6jAe$m zZ59lp%pw~>;=%_@7p?j6t@&}S`Mq27vDSQ5Ykp*Feh+j1%n(kg9cWhFJMlj0fXoGs zCD!}ouXA|IlyL+R2b8dHN!S4;N&gLT7-|0Cdw@s8CT-=%iC=eiFjx@TnAF*W5DD+w!KJ=aNlI#RLUVxS!)u`sKbFV!|yR_auB~HK=v)$Wn z@UBrjm_vtgL&80lJW3)S8FIkgJ4yn-i*BvRxh2by6Y(xYlciqlQ^(tffU3OcW5HRV zS;!gMz|PK8+MIs0(#G6Dtwco=;6w&zxEfpyPFFp;n#}O(s0dR_FV}NV1+mQE#bCJvtlX17>M*HYPK}o-6t+Jap)( z{uO*V^9*;UXevHu$LRE9O74_$;mW}&N+L=>lcIv~JEW*m@g|S7pm`y?lA`wkNlVcd z0eKfFs#W=02O*+|sft~>hE`DZriE4TI{N5wma3Jc<}PuC3TQfjCWg9^!C+x7Tsll*xnsquCljoF8?y0XYb_6Gtae_B@l&dtxk{{Z`=#yxLbea=E=-N$n=~Yt9-jF`IanqLatIFYP zC5MYdx48^C@uf(y+yLTH>Arb{DwY#=vv?XlM<$VpYFFMQxTheV6Lss@a(w0Tb)=fB zsu*_W%FhE2%MQ>g_SRG=G!s(lohmfkiy0_185po_T%t*n*rJ-%F`m;;1UTM5?I`c2Jv&dPs>FaE-7{F;%EQor zAsOhM=N^v|C*_mjrN=tq5a=La`tCx^iO$5-Dr3yEPtGk42vpsoKt~O8I%LS zroC{RaQowwL1->Uy^*uD#xqQZlLk2Va5&i}{_q@5zJg|9IN4u*W?sNXKBVhK@QL?^ zhfnFSfYF4*gJ8^XK!vEIH#nLVjx-!j7GXH)Vx*+JT&XmKLBCoJ`l~4KsRu>uQ`%)I z=|H%XpM|u!DX1-g$Wk{dm&01|_J@%>6b|se=InS8K=zbb8=l)7kXZe{m<#_~Ic0_s zo&`>Kr_6{%$YOo;7#&#dIFv`oZbOd}!4Sx|49GG8S>4olTiKGm0LXk)(usGIXDla`}&V&I*4v*QZJq@+OhsSsj41hd5#wX6ZmQ2(q9)f|lQoPwaMRn(g z!P5JE5bfa2C~ovA3CS= z1kdR#gT0nNz@F2oP5oI|oyT~Xyy840OZ~)88FI4d7E}m<=4lrmB2v28lom}yGZEdAgrF4gWI10{mhv>LYuzPT1CcGFCA8+-R8cW(x83oFD zpmE%MG?HfyPQ@=*=~5g9zRs3srd=mLGmrWZWML)*eDky(}Ju!Nfq#B_&%{B@Gg^1eusD;&% ztbzav!O77M|Kun#QnP?=?6tDo%UEf_&3n)s_}PTNR6vR|BB3=kzF-boB0xQ( zCy2(>BbNPuwfB#f=*ZS1wIf^b>pJqMctJ;Y$j{85;3vC#T063~CObPe_iMMHWJPNmejQqe zD_RFDTE9Y4_KVjSpoQ5osL(6NFZJ0{gr-jceKv|VUN;%)Y6AlG;`;T?oTSE+f4Tbb zRFAL+*U@WJuY}cO)9dB28&)E7{{8R_&X(7v{;JCHH7LjAld+Xo*n&61xZM~ZzD0` zCwQ+7DuPXe)Ek`0-T~a8m#T3=J8BTmNo6K*{SCLF{Y6;bRtih*h7Siz4G!`s#{%e1 zqIaA0wH&mpZ$EX{gKWSVj159G>FQH<1Q5y0+#NsJ(_fKJropVjGue=DHNGhB_`(5o zt=aZS#j$ds`<}vUjhu`pB70EEMT76;(_hFp=Z{R+j$Y?FeeTNb?a36I))PorW$CT;W(CCYn zFF_>9b_AktL-D7KqKDa>ZfBj8pPVHmzl}15|@os7@51;#^V+1z{tqA(`h5_gqYO z&2>n6#vOBuWk>C_Zeay(3E!1yrAoq@?gijl4OetOsF1z5U4(H$RFSsb@lIVGMaSko zNK>vAbJfrV3#rCF@H8TlG{AhS??hue4KMfOxj&d#*5P{WjdeSo!(ooT^vL9s2}}Xw zeVqSo&3%A8B0fn>tGnRIy7FfL*F(y0vrDG2Z*Pb_^rQqRb)Rat0jyWE#O~_>g}~UZ zjGx;wUUwO!jGv)8ti@>9)mZ%JBex}=j#LjsXkr5Q}BA?2JInL;wx;X1 z*3|Ee)z|M#)o*P=_4%(tFK*SV+o4F_KG8uXL-bxH`g=+A5cLp7Dswp&O#bHyZ%|qe z+9*nBHAny>L`Va~KdAiH6eOgipYUcN8LUiZ+1Eh9St{ipduMbffES(@rvlI!jyZQs{ywfG1 z)c_J89-6SsOX$Z(##lX9FM7zD*K_oB3sC6PYe(Ma9urjr0_2!@U;aowZ;`mU8VgpV znjeWO5TOfo^HK&A+O?0ceaaTI8)l#WX$)C)gT>jNlj^dzbbP{`)W+G5kRjPd&RJr1 zB|u+C2kQX(q1syoXx^w9+ZfG?s@z#En{i>{Zb-z{^9NkZ+Y@2>^JRv-VE-1En{Qr) zpKGT)!neO;6y2Qt;+&nk{vN9yz3yOsS+F7dg_95;>ItYP*xCpw!+<4y$XJh}rJz|_ z(2w6^-k0n9m)>XId1vKMhzA7wmJP2QRNmY4|Frk*@ljRR{wEAC6_S9c_^2G;0Wl^a zgm48(API@)MMxAXb{J+R$>?NemXw?~2uW zqxHe9Xt`>=p>S(dijO97?}T?z6-ci>N>a})Tc9R8-p3)C} zH$G7S(T<|Tn{`_K=C=Kt`f_^l{;*$i>92lHS!U`i`HAzu8H}Nt{o|=duOqv>$j1dq zPVXOoohEqP4`97fYyY&3`m7DTOkHIK=cl1TlD!vjENSsmnAD(7z{}SLqj{jFQo-`j zuTY3ibmqz*KgYxe)2?O)Z0eFDEE}(Qb}+fk$%I5e(MuZec4%4tQN`N8$99gc9Zmmn zyA)M62FO!=l!QKhnG<9dswRvjzX4g6u&6ZaFczf@a9IP6vi3vAy2e!2!0{FI5Xixw z-gLdRdhjpHwMNl{bScC*p6(l^BrqRrXc_m zorPIK%iK+Tdse&YpV+mwi9eqM*LgY8;5siN61j1z)-Twg%HTaeQ1=;L>t1bIYjL+_bBeA8zwmRX;XwfWzZhK4U=}h zH@EGy`>9ar&!GfTHdUG(+lbNa$+}v6dB%2oa+t)JpNrd*17m0e-3dR{tBAc&y&GLh zOH#GDKsl&!hhjSeGzv6w_l);_>$`U6kOwbs>ogvmlqu5=Mk978=p}+bFXA>) zAD@zaNjj0KPV)I}c}Vedy3aaUIz95qSB?jTv054NN#686IB6Q-I|WYK2-3FzxAlos zYvCQq)mvyup*QBYSa(jAYMsibJ0I;hhg(~1jm!SXW(`M%e!x6m@Ozoyv!VLP3w^Xi z`EI6DliKe*R9DeC#{0=y^XnSU( zt-rm5lE@qVJfPLzzQ6_g+oufX?l={~TrQvCHqqa(QG$sOc22`J41bU1MBQ^)^$xoe z_0LFG3%}tdFH$Af*-O4zmb^xmycVE;FFtNYn*o;lbQk63V_CbKwe6s6Ux8}R0!8yE@a$AOcY3Szl zaQm`^J*SMpQ}gPjqqR7@r@zyakC%>qV(*bWBEquw$%8fg0(Sr)IUuJu3(a)&S!)cC zS{cUYEU9j%gSi?7kawAeTSpE)npKa%z@By+nwRDQ8a(ALS^6;T981tV>LqPGH^Lj* z0KW&nTdua}$!@6u>g4K)F}dJaT-j2&sIpm(C3sn40SFr4biye3kN0xFsn}e7R}Nk+ z+m5jo2C3T$P1Kur$3!{evVmZ*;1f!GA_LXn=IE5=N`kEV#B0R=qCTCf`TtTiq)*yC z%&br8drGA_^*LSTL)XbZHrH?d0WE5vNUllGlj=YXDN?EqUnV=$unDe>7y3Wk${I6i zy?|Llt{0?tHQPSo`n~IL^)W#mxI2Wsw%wE_NCt_^7 zW)zk=&7;Vgi8)p&>cyv05ZevBVW#05st2N=vP&qqmb zhGiSbfg5FE24ANzNOw0It$x4Qp@rSmU?GQw#Q~P4Ww2(1!(3c zu0v(k!#yA?V=I8SvfxqPi*E51x3Xq|kF}Nck=)9neSX@?I&*j#O?^1PqkI-riALJ) z?`1(SKPill6a~ z7mYUcZE83$yUlXMCuSlix`Xug@`qLAd54i3H#Zz0mnA%4Ie0k%V>gvWumMwRr&UM|%?qY_m7?^1@HPz;UGDQ(Y|* zG~BntoYV&c_q2J>ymO7&1+_)oO z>XPI6Qq>&N4}JE_Zx%kNPzQlJC{Za-f%Aig>sZ(q`U68rEPD^2U(#`^=aJD#_n4xq z1RW^O8BXzpqL`v6=!NRzz(>0tRw3TYla#{p47D8Cr|noe;CA>5y<>qcB-4Xp7C9{0ujILl@L9v{>HfU^!m0 ze2m2FnK?$XoJ=gID3*ub<2pL{(zDO$e6MuyeUcfTa=GODQwDQ;0s3F4%^>PXZ0`?e z`8l4QPu0FvvOEkVM7=_?B)#^>EtVNu;tS+RwZ!}I$mo`Exn)bxl5X?0pTGEg`?gQ> z&i=CU>Uw;BdOB`Zv1j>aWn0~*KUKC?ZW?T>?YZOt(2MJ*4pA%jyNd=z?Q=t}_>|(e z^QNqWqKx`YpVV*qBTo2Lib=n#UH^Pe?d*3Fe?Z%ez2@4=WtG=fexuU;e0zIg-joeQ z4)5mKUp}uOTMj7cT8A8iZmqHSh(^Ov^MZgG_IeZ1sNZLwC`Wf&lB>Q-f&kW!Q}-) zaep)t4thdybCoBU@H5xHg)hsQS;)V=-oyEsPWj`Ve$!S5QVEB@RxgqNWj#mIOe0LjNlgfuPUyL?V7ztQilREBt0G;r04svGznzw+J=M zK|HNVp>N(lY$zeAz@A)2uXXequoWkmG^m>Ao@wmS$5+`m|)s^-2O$#bpt4;Ka zU@+|U#L;gqx*&ED(V4+O$ZwXF7MtOAvz_`9dXVfqh3&J8i~zB8`&NfS!I+)CBn!QR z+{S-KHhPPfq9WRZJOB>GBJZdq3B;1O*bp2 z1C9B{)8)r>V1^Q1D*%vCS3)VB9(1?qR3(IqJRvg>4Ej4T74eL5kvX+-L2K2*>V^iB z{;#5cD4@QrrK+`skoX6(wPkUGspZRD-&A{mMQcsT;ZX=OEiH@c7cHugNY)hRFI0wHs5KsSA&u?yQX=tl&s%~Cf zSKriFUtQCx>q_n08uf%?k#NkPLUODzY{qp`W0Tq1QrWl|H9;+Pq^hZhEX|6EJ|9aS)e(? zaDl$w-yY}d68dkRLHcf~;s3=*HmE#=G+6@m5&_~Re)Dd91;=0TTdGj+W||b4~e~i z4_6O~0l<&zhQwq%%6oYP^nklQ20h?apAU(90iPP36#D>A%1w%+fXOLIVPbh(d~QwHaRXrKO3(wodQVck z4EX1NPKqOdH$9XTOKo_j(2;g_d2{9S>Xy3*M zGAaN|CkwG0@Uzo}pc~ki&Jtn=;6zi1UcgWZ@&VRgF2p3=d;j88EM}gXVDfwCySO1iU?fE8ELPXV9~aM_Mf_- zw`}sBk&<^EXt#F{iu<$4duK{s+6|kyaZsED8_6icv6Q@YBIx702E`58AK-HJfl{^+3CP?Lo=Tw~EL1MRb)4vMea>(*dv=h{@=HiGuZh#@fr z{nL`cPCNcY=1cas8??V0HzY2`m}b$|_qeuOJ_32q?SDbE@UkchM<_(D&jKLP)#;vZNky}QsAMKhk5|m_%%Ru+)f+5jx zp^eUN=j9h#k6Cyur176jdN%#|(p^h`#+bHB#4#FOUlmZeECXdjz2&%?5x6J0Op zF2vUB?e=`e>2S`6}f)EQG{O4PB8i_UK6<7-{!%nm%r+s|7VxnaSMW9`Kp%Cxd=XPDEzSO+F z1aw7MHx}RsO-7!lp29r2{-B+X*J)bION{dOY#5%{G4#UcOWEI--iUZgL;o*CU6 zSY@TgfL$~n5#15cz1=Lt?{TouqSLa!b%rI+B+S9v@wVaz95(WQSf2&RT8i{3AtByJ z|FQVkZQvC-|4`kQgZ9lh&Z0SZ?Xuct9n!DI>k;2~q`zyGwFBve_-IdYwl&XLvX7En zw8o!-we@Le?~HPdNR7pxgZAt@gt+P4EVO}hSs%pre6)4sXF|McZ*zNn_oUjr88oN- z9QCocg`M^lY7IGW+yL5_pTpYSuE*4v@&;*<+HEK3w(Jw)9lMTnyGb+Waph&uRpQ2+=IX#t#a%-diw;c%pIT|zIYxkZ(^1@m*w`MHzl=jPAP9c$1{P$_J2JNRHq{d@Sk2L7&r3>t`>Cy_-8 z(vU$R9flM_PD zs%3Pm1iD3~po%kaFqy+HRdJ0UPz7nZdlelGr4)4ev`nR->2Sh<>j(8R3a2Ib+ED!9 z2jy!i9mZUBeZQ*c7wTHqLvsJ$`|nomlFqTrl$aU?uTrpG!Bq-=OToJpykEhm6#Q2O z-&F8J1&=8>`W%D9sR~}GV3~q73SOmPyMn6}{FZ`uD|o+xPbv7X3cjh}hYB83a5Sw$ z5KdL_LIukdtWoeP1=|%|rJ&6H)&Iwux}}|YavYZf^V0W4RdR(B4$K=mIs#cEc!es3 zT@?(BNTr0S|MfR7Sv}!|eB*on@6jb6ANc6zO$}$i@y>`Hb0pj~N38i#^T}1ev3%}M zc?|BC)ED*7M4W0e0>3Hv!H#dHIQ4^D=>l*jej^5P0pne`V8K6_1#K%5p?JcaU07OJ zbV+f7uZnLfDJm=~ohq@&@)v^(quGO0SXyvFn!OqEE~7sqexyPEr}W@LZS{C#PjjL6 zdR%hi#~8Z5I`Qc8dVsPexQr7FJ)YRm@ROft=yAu12NTndk#QGBXEP&yys_@wO!T?N zwv6~ZYdp8-a?z@5V7P)@#ss7Ji%j^5M*d(X{K?k*;N(Banirh-Q;baGlFK;N8poaV zr$Il%`<08Vk>1Ii7F^b>l}aFcA8C9nQWzPdX<&qrYxJh+ja(OmA4tQWqwsqEm0aLE zKqSW|50yuu2EQD5?e+Y~Nc?r-NBs4CuJLOS$uWlOb35>v&NId(Ofg6KMqJJ%4;@L+G{A7hM`~(*W?7Ide zwnYB`JDUuHeb2y`D*T@>mwebK41A@gzjOqypmzz3B?|v;u|%+s5$WUyBmP?hk`McV zfxlhhrCuNmW{rxS`)?r8i|VBaqwJ&H_t zy!?gn>}y7By29W8vBWPY14LK|e5Q7920jO?8B_HO-3zW^{A6RS>KA&Q(xLGAY50|j zPl4j2>DMZJQ5t@|!k4F&OK*lE`=6Y~pVpZqXGI#H`xL#IM*pb77o_3;Me(Uk4Z zx1CE|4C7J>jQbUzyGc<9?E3Ts{Bt104eI&j79lp7c|jrk}eNeN~^7 zpM991|DnP!q?dId@V*M*j~UM>$KNwq@cXmi$KVDblb-4P3)#u5#gaXrDL{0Z!k_aS zDJT0-fiF?`>8m6?@6#iCWfuNkMgQ7ulAibK5nZeBkG?7Svkw*cTeI-_De$Ib;rM?E z_zAZ4Fq)ggZy7(?Xin4rG3JkT(F9p8@1Y>a5aU&58>JiIXrpGO#cVXB z4~ow#^y)#G#JP4OAJPU85C3Zmat_zl-d`FWoh z_#Y|$>HdO86n#XE^L|yt9)*AVDk&%LH6e}m=&0X)?U>}x`-{N;O5u0@UedFlANbc8 zubA4vAAzTFW=Wczp9lw7rgkZ0e6H~&Ei4gupB%7E;iug#%jJC_;OPkyl5^ctlAiac zfv?HJ{~KBGu`KxSD*k^yBKh+^F8KdY;qRR#<>7rp;C~E!KI)s^zCTm+d+R0rjvNpp zJfrZB%$5B4tO4-9Q1~@_B|Yy?0sjKyDW@~Mujs#=Bk_Em3emwV^b_DG%w*3O08jdS z_F`Es@0)_pbcIiTUCPPl9Dtv}cv+_Xe`yx{x3l2CulNtXA3Kw9hQ1f z>M;5g{=ugup7(4~?tX<|bDor+&mJQBj>4C#brGKh0saGpzv7#c5ARx8*jzVSm zGfQCkd_k|BTvo#! z^oQK2P?v)myrXWTu!CgxMg#Ex1_E~?1|*&rO?cg~1HGde@k}Rb z=TK$PvoZqB`+}Zmdxu-ux!V^FV}vw(N^uKGAy!EtQaiH*FRdz{r#rF+IaY^)@#4(F zc{}~y>)in;faQypP_Z$801d-W?Kve=x|gDNc>*D4G8Y^SqrpSr5b79?heH889J>b6 z0ouhYg~0 zAWu7*i5OBFu14ee!6{`3?z+|nJmIV7sn&)CG)uL5Rs{WqyRHfK@&!WF*1qGkKgPdM zv5}ZPss9 z-P?($$hmX8)gf}vv8}?fm35qdm`j@$GHj6uj1`ww>0+>4H`%dk#?c&)<@&WFbm;+5~K0K z?Tdxoop@%M8aOrF&?rh4=?|?!X}&P(MP*0ZRsCWZ#4zB} zNG`RoA{J9N6YzPuJl!Nh3?qXt3`0hzbWYg6HxEtO z&7{P@L`s93y|eqNOJ`uoyix+`)^-Y%wji|WpZb-WeIpIE;nfI*f~ zmGkQ^iF-OQ0MS>=z$@L;mz!i_X6#ypfk#UjDDQOF&<5K*)R zF5@s4qmXVWKon+u7y3KZEkvgeO!Sq^D(@v^4jor>A7rBDDnyqu3UMDpuY!>GME{e2 zI=4l4jOw=5I$xpBS?F_Hx(wy^(3b|?-obTe<=5vhG(6v;lo9Pe)#x%r?D_S14Gm3A zs9<{jD&X;WU0BPn&vj_1%ZJ;V1Ke4T(1h8^F<7Fr8nYC()4jQ_%8jIt{N!8l5fE*IXIOK$Sumkbuwc zP*t@23T>=Kgz!4QKA)mtuOigt>-@U@8&v-JicX(n(Xd<9pYorIUwZznz>!W!zZ^^_ z)aMEnmSxp(f}8NO=QmBl8rJ!k<+@@LO`d!X8s3E~dwzX>Mnf&H%4W&0@jpn*ulK_= zZ2Ps-0Cc&U-+gKM_4!H-^|?z;ugpUSDhY259o|)A{vzn#fno z{~yRpwx{#!^GDq(zo`_X?NgVl^+@~Wq(7ZspEuo}E9LK`L|f4LHT(n8?D-Aa=%qjp zrc+4EZ!$9VH-ISd(&bxz>j|p-6e-7axf=Z^M5u@&jnGi#pQ^7F)Z*BowjDcZk;-47 w4%$*bUV@)4UymPTo|f!321_oG@}FQGM3#xVTunM5OMXwW%%9YR3a01(Zxq{=cK`qY literal 0 HcmV?d00001 diff --git a/c_binding/test_install.c b/extras/c_binding/test_install.c similarity index 60% rename from c_binding/test_install.c rename to extras/c_binding/test_install.c index f34b97c..2bcaa1f 100644 --- a/c_binding/test_install.c +++ b/extras/c_binding/test_install.c @@ -1,61 +1,7 @@ #include #include #include - -// serial subroutine: no optional arguments -extern void c_delaunaysparses(int *d, int *n, double pts[], int *m, double q[], - int simps[], double weights[], int ierr[]); - -// serial: compute interpolant values -extern void c_delaunaysparses_interp(int *d, int *n, double pts[], int *m, - double q[], int simps[], double weights[], - int ierr[], int *ir, double interp_in[], - double interp_out[]); - -// serial: optional arguments, no interpolant values -extern void c_delaunaysparses_opts(int *d, int *n, double pts[], int *m, - double q[],int simps[], double weights[], - int ierr[], double *eps, double *extrap, - double rnorm[], int *ibudget, bool *chain, - bool *exact); - -// serial: optional arguments and compute interpolant values -extern void c_delaunaysparses_interp_opts(int *d, int *n, double pts[], int *m, - double q[],int simps[], - double weights[], int ierr[], - int *ir, double interp_in[], - double interp_out[], double *eps, - double *extrap, double rnorm[], - int *ibudget, bool *chain, - bool *exact); - - -// parallel: no optional arguments -extern void c_delaunaysparsep(int *d, int *n, double pts[], int *m, double q[], - int simps[], double weights[], int ierr[]); - -// parallel: compute interpolant values -extern void c_delaunaysparsep_interp(int *d, int *n, double pts[], int *m, - double q[], int simps[], double weights[], - int ierr[], int *ir, double interp_in[], - double interp_out[]); - -// parallel: optional arguments, no interpolant values -extern void c_delaunaysparsep_opts(int *d, int *n, double pts[], int *m, - double q[],int simps[], double weights[], - int ierr[], double *eps, double *extrap, - double rnorm[], int *ibudget, bool *chain, - bool *exact, int *pmode); - -// parallel: optional arguments and compute interpolant values -extern void c_delaunaysparsep_interp_opts(int *d, int *n, double pts[], int *m, - double q[],int simps[], - double weights[], int ierr[], - int *ir, double interp_in[], - double interp_out[], double *eps, - double *extrap, double rnorm[], - int *ibudget, bool *chain, - bool *exact, int *pmode); +#include "delsparse.h" int main() { // Set the problem dimensions diff --git a/python/LICENSE b/extras/delsparsepy/LICENSE similarity index 100% rename from python/LICENSE rename to extras/delsparsepy/LICENSE diff --git a/python/README b/extras/delsparsepy/README similarity index 100% rename from python/README rename to extras/delsparsepy/README diff --git a/python/delsparse.py b/extras/delsparsepy/delsparse.py similarity index 100% rename from python/delsparse.py rename to extras/delsparsepy/delsparse.py diff --git a/python/blas.f b/extras/delsparsepy/delsparse_src/blas.f similarity index 100% rename from python/blas.f rename to extras/delsparsepy/delsparse_src/blas.f diff --git a/python/delsparse.f90 b/extras/delsparsepy/delsparse_src/delsparse.f90 similarity index 100% rename from python/delsparse.f90 rename to extras/delsparsepy/delsparse_src/delsparse.f90 diff --git a/python/delsparse_bind_c.f90 b/extras/delsparsepy/delsparse_src/delsparse_bind_c.f90 similarity index 100% rename from python/delsparse_bind_c.f90 rename to extras/delsparsepy/delsparse_src/delsparse_bind_c.f90 diff --git a/python/lapack.f b/extras/delsparsepy/delsparse_src/lapack.f similarity index 100% rename from python/lapack.f rename to extras/delsparsepy/delsparse_src/lapack.f diff --git a/python/real_precision.f90 b/extras/delsparsepy/delsparse_src/real_precision.f90 similarity index 100% rename from python/real_precision.f90 rename to extras/delsparsepy/delsparse_src/real_precision.f90 diff --git a/src/slatec.f b/extras/delsparsepy/delsparse_src/slatec.f old mode 100644 new mode 100755 similarity index 98% rename from src/slatec.f rename to extras/delsparsepy/delsparse_src/slatec.f index 7d51578..c652a26 --- a/src/slatec.f +++ b/extras/delsparsepy/delsparse_src/slatec.f @@ -7,7 +7,7 @@ SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, C a covariance matrix. C***LIBRARY SLATEC C***CATEGORY K1A2A, D9 -C***TYPE REAL(KIND=R8) (LSEI-S, DLSEI-D) +C***TYPE DOUBLE PRECISION (LSEI-S, DLSEI-D) C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, C QUADRATIC PROGRAMMING @@ -62,7 +62,7 @@ SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, C C The parameters for DLSEI( ) are C -C Input.. All TYPE REAL variables are REAL(KIND=R8) +C Input.. All TYPE REAL variables are DOUBLE PRECISION C C W(*,*),MDW, The array W(*,*) is doubly subscripted with C ME,MA,MG,N first dimensioning parameter equal to MDW. @@ -268,7 +268,7 @@ SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, C LIP = MG+2*N+2 C This test will not be made if IP(2).LE.0. C -C Output.. All TYPE REAL variables are REAL(KIND=R8) +C Output.. All TYPE REAL variables are DOUBLE PRECISION C C X(*),RNORME, The array X(*) contains the solution parameters C RNORML if the integer output flag MODE = 0 or 1. @@ -382,18 +382,17 @@ SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, C 900510 Convert XERRWV calls to XERMSG calls. (RWC) C 900604 DP version created from SP version. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Removed prints and replaced DP --> REAL(KIND=R8). (THC) +C 180613 Removed prints and replaced DP --> DOUBLE PRECISION. (THC) C***END PROLOGUE DLSEI - USE REAL_PRECISION INTEGER IP(3), MA, MDW, ME, MG, MODE, N - REAL(KIND=R8) PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*) + DOUBLE PRECISION PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*) C EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, DNRM2, * DSCAL, DSWAP - REAL(KIND=R8) D1MACH, DASUM, DDOT, DNRM2 + DOUBLE PRECISION D1MACH, DASUM, DDOT, DNRM2 C - REAL(KIND=R8) DRELPR, ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, + DOUBLE PRECISION DRELPR, ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, * SN, SNMAX, T, TAU, UJ, UP, VJ, XNORM, XNRME INTEGER I, IMAX, J, JP1, K, KEY, KRANKE, LAST, LCHK, LINK, M, * MAPKE1, MDEQC, MEND, MEP1, N1, N2, NEXT, NLINK, NOPT, NP1, @@ -743,7 +742,7 @@ SUBROUTINE DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, C***SUBSIDIARY C***PURPOSE Subsidiary to DLSEI C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (LSI-S, DLSI-D) +C***TYPE DOUBLE PRECISION (LSI-S, DLSI-D) C***AUTHOR Hanson, R. J., (SNLA) C***DESCRIPTION C @@ -795,16 +794,15 @@ SUBROUTINE DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, C 900604 DP version created from SP version. (RWC) C 920422 Changed CALL to DHFTI to include variable MA. (WRB) C***END PROLOGUE DLSI - USE REAL_PRECISION INTEGER IP(*), MA, MDW, MG, MODE, N - REAL(KIND=R8) PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*) + DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*) C EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, DLPDP, * DSCAL, DSWAP - REAL(KIND=R8) D1MACH, DASUM, DDOT + DOUBLE PRECISION D1MACH, DASUM, DDOT C - REAL(KIND=R8) ANORM, DRELPR, FAC, GAM, RB, TAU, TOL, XNORM, + DOUBLE PRECISION ANORM, DRELPR, FAC, GAM, RB, TAU, TOL, XNORM, * TMP_NORM(1) INTEGER I, J, K, KEY, KRANK, KRM1, KRP1, L, LAST, LINK, M, MAP1, * MDLPDP, MINMAN, N1, N2, N3, NEXT, NP1 @@ -1079,12 +1077,12 @@ SUBROUTINE DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, RETURN END *DECK D1MACH - REAL(KIND=R8) FUNCTION D1MACH (I) + DOUBLE PRECISION FUNCTION D1MACH (I) C***BEGIN PROLOGUE D1MACH C***PURPOSE Return floating point machine dependent constants. C***LIBRARY SLATEC C***CATEGORY R1 -C***TYPE REAL(KIND=R8) (R1MACH-S, D1MACH-D) +C***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) C***KEYWORDS MACHINE CONSTANTS C***AUTHOR Fox, P. A., (Bell Labs) C Hall, A. D., (Bell Labs) @@ -1151,7 +1149,6 @@ REAL(KIND=R8) FUNCTION D1MACH (I) C comments below. (DWL) C***END PROLOGUE D1MACH C - USE REAL_PRECISION INTEGER SMALL(4) INTEGER LARGE(4) @@ -1164,7 +1161,7 @@ REAL(KIND=R8) FUNCTION D1MACH (I) C for DMACH(2) is a slight lower bound. The value for DMACH(5) is C a 20-digit approximation. If one of the sets of initial data below C is preferred, do the necessary commenting and uncommenting. (DWL) - REAL(KIND=R8) DMACH(5) + DOUBLE PRECISION DMACH(5) DATA DMACH / 2.23D-308, 1.79D+308, 1.111D-16, 2.222D-16, 1 0.30102999566398119521D0 / SAVE DMACH @@ -1387,7 +1384,7 @@ REAL(KIND=R8) FUNCTION D1MACH (I) C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / C C MACHINE CONSTANTS FOR THE ELXSI 6400 -C (ASSUMING REAL*8 IS THE DEFAULT REAL(KIND=R8)) +C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) C C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / @@ -1420,7 +1417,7 @@ REAL(KIND=R8) FUNCTION D1MACH (I) C DATA DMACH(5) / Z'3FD34413509F79FF' / C C MACHINE CONSTANTS FOR THE HP 2100 -C THREE WORD REAL(KIND=R8) OPTION WITH FTN4 +C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / @@ -1429,7 +1426,7 @@ REAL(KIND=R8) FUNCTION D1MACH (I) C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / C C MACHINE CONSTANTS FOR THE HP 2100 -C FOUR WORD REAL(KIND=R8) OPTION WITH FTN4 +C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA SMALL(1), SMALL(2) / 40000B, 0 / C DATA SMALL(3), SMALL(4) / 0, 1 / @@ -1461,7 +1458,7 @@ REAL(KIND=R8) FUNCTION D1MACH (I) C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / C C MACHINE CONSTANTS FOR THE IBM PC -C ASSUMES THAT ALL ARITHMETIC IS DONE IN REAL(KIND=R8) +C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. C C DATA SMALL(1) / 2.23D-308 / @@ -2176,7 +2173,7 @@ INTEGER FUNCTION I1MACH (I) C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE HP 2100 -C 3 WORD REAL(KIND=R8) OPTION WITH FTN4 +C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / @@ -2196,7 +2193,7 @@ INTEGER FUNCTION I1MACH (I) C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE HP 2100 -C 4 WORD REAL(KIND=R8) OPTION WITH FTN4 +C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / @@ -2507,11 +2504,11 @@ SUBROUTINE DH12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV, C***SUBSIDIARY C***PURPOSE Subsidiary to DHFTI, DLSEI and DWNNLS C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (H12-S, DH12-D) +C***TYPE DOUBLE PRECISION (H12-S, DH12-D) C***AUTHOR (UNKNOWN) C***DESCRIPTION C -C *** REAL(KIND=R8) VERSION OF H12 ****** +C *** DOUBLE PRECISION VERSION OF H12 ****** C C C.L.Lawson and R.J.Hanson, Jet Propulsion Laboratory, 1973 Jun 12 C to appear in 'Solving Least Squares Problems', Prentice-Hall, 1974 @@ -2548,13 +2545,12 @@ SUBROUTINE DH12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV, C 890831 Modified array declarations. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) -C 900911 Added DDOT to REAL(KIND=R8) statement. (WRB) +C 900911 Added DDOT to DOUBLE PRECISION statement. (WRB) C***END PROLOGUE DH12 - USE REAL_PRECISION INTEGER I, I2, I3, I4, ICE, ICV, INCR, IUE, J, KL1, KL2, KLP, * L1, L1M1, LPIVOT, M, MML1P2, MODE, NCV - REAL(KIND=R8) B, C, CL, CLINV, ONE, UL1M1, SM, U, UP, DDOT + DOUBLE PRECISION B, C, CL, CLINV, ONE, UL1M1, SM, U, UP, DDOT DIMENSION U(IUE,*), C(*) C BEGIN BLOCK PERMITTING ...EXITS TO 140 C***FIRST EXECUTABLE STATEMENT DH12 @@ -2654,7 +2650,7 @@ SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, C Exactly one right-hand side vector is permitted. C***LIBRARY SLATEC C***CATEGORY D9 -C***TYPE REAL(KIND=R8) (HFTI-S, DHFTI-D) +C***TYPE DOUBLE PRECISION (HFTI-S, DHFTI-D) C***KEYWORDS CURVE FITTING, LEAST SQUARES C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) @@ -2711,7 +2707,7 @@ SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, C C The entire set of parameters for DHFTI are C -C INPUT.. All TYPE REAL variables are REAL(KIND=R8) +C INPUT.. All TYPE REAL variables are DOUBLE PRECISION C C A(*,*),MDA,M,N The array A(*,*) initially contains the M by N C matrix A of the least squares problem AX = B. @@ -2742,7 +2738,7 @@ SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, C C H(*),G(*),IP(*) Arrays of working space used by DHFTI. C -C OUTPUT.. All TYPE REAL variables are REAL(KIND=R8) +C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION C C A(*,*) The contents of the array A(*,*) will be C modified by the subroutine. These contents @@ -2782,11 +2778,10 @@ SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, C 901005 Replace usage of DDIFF with usage of D1MACH. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DHFTI - USE REAL_PRECISION INTEGER I, II, IOPT, IP(*), IP1, J, JB, JJ, K, KP1, KRANK, L, * LDIAG, LMAX, M, MDA, MDB, N, NB, NERR - REAL(KIND=R8) A, B, D1MACH, DZERO, FACTOR, + DOUBLE PRECISION A, B, D1MACH, DZERO, FACTOR, * G, H, HMAX, RELEPS, RNORM, SM, SM1, SZERO, TAU, TMP DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*) SAVE RELEPS @@ -2985,7 +2980,7 @@ SUBROUTINE DLPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, C***SUBSIDIARY C***PURPOSE Subsidiary to DLSEI C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (LPDP-S, DLPDP-D) +C***TYPE DOUBLE PRECISION (LPDP-S, DLPDP-D) C***AUTHOR Hanson, R. J., (SNLA) C Haskell, K. H., (SNLA) C***DESCRIPTION @@ -3028,12 +3023,11 @@ SUBROUTINE DLPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, C 900328 Added TYPE section. (WRB) C 910408 Updated the AUTHOR section. (WRB) C***END PROLOGUE DLPDP - USE REAL_PRECISION C INTEGER I, IS(*), IW, IX, J, L, M, MDA, MODE, MODEW, N, N1, N2, * NP1 - REAL(KIND=R8) A(MDA,*), DDOT, DNRM2, FAC, ONE, + DOUBLE PRECISION A(MDA,*), DDOT, DNRM2, FAC, ONE, * PRGOPT(*), RNORM, SC, WNORM, WS(*), X(*), YNORM, ZERO SAVE ZERO, ONE, FAC DATA ZERO,ONE /0.0D0,1.0D0/, FAC /0.1D0/ @@ -3197,7 +3191,7 @@ SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, C selected variables. C***LIBRARY SLATEC C***CATEGORY K1A2A -C***TYPE REAL(KIND=R8) (WNNLS-S, DWNNLS-D) +C***TYPE DOUBLE PRECISION (WNNLS-S, DWNNLS-D) C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, C NONNEGATIVITY CONSTRAINTS, QUADRATIC PROGRAMMING @@ -3232,7 +3226,7 @@ SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, C C The parameters for DWNNLS are C -C INPUT.. All TYPE REAL variables are REAL(KIND=R8) +C INPUT.. All TYPE REAL variables are DOUBLE PRECISION C C W(*,*),MDW, The array W(*,*) is double subscripted with first C ME,MA,N,L dimensioning parameter equal to MDW. For this @@ -3392,7 +3386,7 @@ SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, C LIW = ME+MA+N C This test will not be made if IWORK(2).LE.0. C -C OUTPUT.. All TYPE REAL variables are REAL(KIND=R8) +C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION C C X(*) An array dimensioned at least N, which will C contain the N components of the solution vector @@ -3455,13 +3449,12 @@ SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, C 900510 Convert XERRWV calls to XERMSG calls, change Prologue C comments to agree with WNNLS. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Removed prints and replaced DP --> REAL(KIND=R8). (THC) +C 180613 Removed prints and replaced DP --> DOUBLE PRECISION. (THC) C***END PROLOGUE DWNNLS - USE REAL_PRECISION INTEGER IWORK(*), L, L1, L2, L3, L4, L5, LIW, LW, MA, MDW, ME, * MODE, N - REAL(KIND=R8) PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) + DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) C CHARACTER*8 XERN1 C***FIRST EXECUTABLE STATEMENT DWNNLS MODE = 0 @@ -3525,7 +3518,7 @@ SUBROUTINE DWNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, C***SUBSIDIARY C***PURPOSE Subsidiary to DWNNLS C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (WNLSM-S, DWNLSM-D) +C***TYPE DOUBLE PRECISION (WNLSM-S, DWNLSM-D) C***AUTHOR Hanson, R. J., (SNLA) C Haskell, K. H., (SNLA) C***DESCRIPTION @@ -3539,7 +3532,7 @@ SUBROUTINE DWNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, C sequence from DWNNLS for purposes of variable dimensioning). C Their contents will in general be of no interest to the user. C -C Variables of type REAL are REAL(KIND=R8). +C Variables of type REAL are DOUBLE PRECISION. C C IPIVOT(*) C An array of length N. Upon completion it contains the @@ -3590,18 +3583,17 @@ SUBROUTINE DWNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, C 900604 DP version created from SP version. (RWC) C 900911 Restriction on value of ALAMDA included. (WRB) C***END PROLOGUE DWNLSM - USE REAL_PRECISION INTEGER IPIVOT(*), ITYPE(*), L, MA, MDW, MME, MODE, N - REAL(KIND=R8) D(*), H(*), PRGOPT(*), RNORM, SCALE(*), TEMP(*), + DOUBLE PRECISION D(*), H(*), PRGOPT(*), RNORM, SCALE(*), TEMP(*), * W(MDW,*), WD(*), X(*), Z(*) C EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, SLATEC_DROTM, * SLATEC_DROTMG, DSCAL, DSWAP, DWNLIT, IDAMAX, XERMSG - REAL(KIND=R8) D1MACH, DASUM, DNRM2 + DOUBLE PRECISION D1MACH, DASUM, DNRM2 INTEGER IDAMAX C - REAL(KIND=R8) ALAMDA, ALPHA, ALSQ, AMAX, BLOWUP, BNORM, + DOUBLE PRECISION ALAMDA, ALPHA, ALSQ, AMAX, BLOWUP, BNORM, * DOPE(3), DRELPR, EANORM, FAC, SM, SPARAM(5), T, TAU, WMAX, Z2, * ZZ INTEGER I, IDOPE(3), IMAX, ISOL, ITEMP, ITER, ITMAX, IWMAX, J, @@ -4177,7 +4169,7 @@ SUBROUTINE SLATEC_DROTM (N, DX, INCX, DY, INCY, DPARAM) C***PURPOSE Apply a modified Givens transformation. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1A8 -C***TYPE REAL(KIND=R8) (SROTM-S, DROTM-D) +C***TYPE DOUBLE PRECISION (SROTM-S, DROTM-D) C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) @@ -4231,9 +4223,8 @@ SUBROUTINE SLATEC_DROTM (N, DX, INCX, DY, INCY, DPARAM) C 920501 Reformatted the REFERENCES section. (WRB) C 180613 Renamed SLATEC_DROTM to avoid BLAS naming conflict. (THC) C***END PROLOGUE SLATEC_DROTM - USE REAL_PRECISION - REAL(KIND=R8) DFLAG, DH12, DH22, DX, TWO, Z, DH11, DH21, + DOUBLE PRECISION DFLAG, DH12, DH22, DX, TWO, Z, DH11, DH21, 1 DPARAM, DY, W, ZERO DIMENSION DX(*), DY(*), DPARAM(5) SAVE ZERO, TWO @@ -4346,7 +4337,7 @@ SUBROUTINE SLATEC_DROTMG (DD1, DD2, DX1, DY1, DPARAM) C***PURPOSE Construct a modified Givens transformation. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1B10 -C***TYPE REAL(KIND=R8) (SROTMG-S, DROTMG-D) +C***TYPE DOUBLE PRECISION (SROTMG-S, DROTMG-D) C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) @@ -4400,9 +4391,8 @@ SUBROUTINE SLATEC_DROTMG (DD1, DD2, DX1, DY1, DPARAM) C 920501 Reformatted the REFERENCES section. (WRB) C 180613 Renamed SLATEC_DROTMG to avoid BLAS naming conflict. (THC) C***END PROLOGUE SLATEC_DROTMG - USE REAL_PRECISION - REAL(KIND=R8) GAM, ONE, RGAMSQ, DD1, DD2, DH11, DH12, DH21, + DOUBLE PRECISION GAM, ONE, RGAMSQ, DD1, DD2, DH11, DH12, DH21, 1 DH22, DPARAM, DP1, DP2, DQ1, DQ2, DU, DY1, ZERO, 2 GAMSQ, DFLAG, DTEMP, DX1, TWO DIMENSION DPARAM(5) @@ -4579,7 +4569,7 @@ SUBROUTINE DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, C***SUBSIDIARY C***PURPOSE Subsidiary to DWNNLS C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (WNLIT-S, DWNLIT-D) +C***TYPE DOUBLE PRECISION (WNLIT-S, DWNLIT-D) C***AUTHOR Hanson, R. J., (SNLA) C Haskell, K. H., (SNLA) C***DESCRIPTION @@ -4605,10 +4595,9 @@ SUBROUTINE DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, C 900328 Added TYPE section. (WRB) C 900604 DP version created from SP version. . (RWC) C***END PROLOGUE DWNLIT - USE REAL_PRECISION INTEGER IDOPE(*), IPIVOT(*), ITYPE(*), L, M, MDW, N - REAL(KIND=R8) DOPE(*), H(*), RNORM, SCALE(*), W(MDW,*) + DOUBLE PRECISION DOPE(*), H(*), RNORM, SCALE(*), W(MDW,*) LOGICAL DONE C EXTERNAL DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, @@ -4616,7 +4605,7 @@ SUBROUTINE DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, INTEGER IDAMAX LOGICAL DWNLT2 C - REAL(KIND=R8) ALSQ, AMAX, EANORM, FACTOR, HBAR, RN, SPARAM(5), + DOUBLE PRECISION ALSQ, AMAX, EANORM, FACTOR, HBAR, RN, SPARAM(5), * T, TAU INTEGER I, I1, IMAX, IR, J, J1, JJ, JP, KRANK, L1, LB, LEND, ME, * MEND, NIV, NSOLN @@ -4869,7 +4858,7 @@ SUBROUTINE DWNLT1 (I, LEND, MEND, IR, MDW, RECALC, IMAX, HBAR, H, C***SUBSIDIARY C***PURPOSE Subsidiary to WNLIT C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (WNLT1-S, DWNLT1-D) +C***TYPE DOUBLE PRECISION (WNLT1-S, DWNLT1-D) C***AUTHOR Hanson, R. J., (SNLA) C Haskell, K. H., (SNLA) C***DESCRIPTION @@ -4885,10 +4874,9 @@ SUBROUTINE DWNLT1 (I, LEND, MEND, IR, MDW, RECALC, IMAX, HBAR, H, C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) C 900604 DP version created from SP version. (RWC) C***END PROLOGUE DWNLT1 - USE REAL_PRECISION INTEGER I, IMAX, IR, LEND, MDW, MEND - REAL(KIND=R8) H(*), HBAR, SCALE(*), W(MDW,*) + DOUBLE PRECISION H(*), HBAR, SCALE(*), W(MDW,*) LOGICAL RECALC C EXTERNAL IDAMAX @@ -4934,7 +4922,7 @@ LOGICAL FUNCTION DWNLT2 (ME, MEND, IR, FACTOR, TAU, SCALE, WIC) C***SUBSIDIARY C***PURPOSE Subsidiary to WNLIT C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (WNLT2-S, DWNLT2-D) +C***TYPE DOUBLE PRECISION (WNLT2-S, DWNLT2-D) C***AUTHOR Hanson, R. J., (SNLA) C Haskell, K. H., (SNLA) C***DESCRIPTION @@ -4964,12 +4952,11 @@ LOGICAL FUNCTION DWNLT2 (ME, MEND, IR, FACTOR, TAU, SCALE, WIC) C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) C 900604 DP version created from SP version. (RWC) C***END PROLOGUE DWNLT2 - USE REAL_PRECISION - REAL(KIND=R8) FACTOR, SCALE(*), TAU, WIC(*) + DOUBLE PRECISION FACTOR, SCALE(*), TAU, WIC(*) INTEGER IR, ME, MEND C - REAL(KIND=R8) RN, SN, T + DOUBLE PRECISION RN, SN, T INTEGER J C C***FIRST EXECUTABLE STATEMENT DWNLT2 @@ -4995,7 +4982,7 @@ SUBROUTINE DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) C***SUBSIDIARY C***PURPOSE Subsidiary to WNLIT C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (WNLT3-S, DWNLT3-D) +C***TYPE DOUBLE PRECISION (WNLT3-S, DWNLT3-D) C***AUTHOR Hanson, R. J., (SNLA) C Haskell, K. H., (SNLA) C***DESCRIPTION @@ -5011,14 +4998,13 @@ SUBROUTINE DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) C 900604 DP version created from SP version. (RWC) C***END PROLOGUE DWNLT3 - USE REAL_PRECISION INTEGER I, IMAX, IPIVOT(*), M, MDW - REAL(KIND=R8) H(*), W(MDW,*) + DOUBLE PRECISION H(*), W(MDW,*) C EXTERNAL DSWAP C - REAL(KIND=R8) T + DOUBLE PRECISION T INTEGER ITEMP C C***FIRST EXECUTABLE STATEMENT DWNLT3 diff --git a/python/example.py b/extras/delsparsepy/example.py similarity index 100% rename from python/example.py rename to extras/delsparsepy/example.py diff --git a/src/delsparsep b/src/delsparsep new file mode 100755 index 0000000000000000000000000000000000000000..eafb2529e269134ebd9ca4e0ed5a7896a83683d1 GIT binary patch literal 231136 zcmeFa4SbzdmG6H}lR|*vlVXceQ8F5|6~Po+OlYeKB=8(Kfe0;>5ol{@DGao=B+?mq z2_y&l`0$i!33k+IW|Xm4eK1)BT)t^J(z6sX=i z_x|r^KL5*s=6Uw}+H0@1_S$Q&y`O99(Bs@(p53l4KB z`Ddckg;j2%Ud#1|U%CAqe|C>KK=RMRa@JmX-2XQ`*B$HX$v+Fr2{)DJxpI}4?)!W$ zuC6BEnHWw%p>j2Gxth3K{#hR5EC0;nQ`P9-J#qRQpLL|^mwzg+evMByU#Rz;A9et} z@i{N9FaOM!`!wYQ=l|?4?q1@|xV`=1Whll={;6@(?_-x<{MqAYe(cf( zP<_gypYq4uv*!%LN_YLbmbXMgar$jr^3Y}O?XCZwLv&1f`($`zKk+}I@wdvqc0chq z?WdkD0Dh}_TK1Dax1V^`QO>_N{$2w?Z&m+Y`)T)~{lG7Jf2(>vv!D1c?Wf%z?kE1R z{lN2gbg2A|og#eQe(K5XCw|X<;GDak`d{7;JR-2S!oyYjiJ!WkcK>xh@!R(UfA4mabUUylU}sNy}M@g$pmbY{l}0 zmp3n7)x2)ftXgu>#g{iPSv9ZWq)S&UUovm;XD?mi(%w2HU*|$qeEHHP zs}`nj2B;4kkYhbdDG%%z)*&Q_{*DB(}e{w z7cU2{GY-01xQH&i5&H2Ai&w2$ z{Eu%+22?BY#+FuGzHrH^RV!A#RZ~sN7Oz^|M2Fr~+p3o3%@<#`#1&n*xVfM-4K-c5 z;_`iZv!t2sG+(@8`Q`g&+;1P^P8Q~-j>W4kDy(1}*Kfe|MPzMSaoJ^ymtUwNEtf4> z-n{VQnFW>Yi>m}=cbVwz_{62FRx~E?cP#GZMTkRQ*?2_YtdRqvx}RciRFuhGBW0CXMW< zlz7>S&qEyxRop?h@Uq1hFHbC8wPZ=+lyvIElNKI#>~S#v`1>bZyEBiiObFk{@ibJ= zR3^pDP)uBM#>~ViC!cZVyfbT0UsxpxGlBn#(7W{1f6}cLQ-tnxpuHy&C8Q&i;v5r+ z)qfNCcMyLMCQT(v_;&#RT*%dS2%#i#tEpHzTP6Qm-gEImsz^vr7+-r`S9=x7cZR^1dac87Q`Pq9-ByH3*rms{gHzB!wd3{7R2XuVI{9# z?%JhO*3W#A)`ED^MgF&@Al{X9DeDU2W7Jr}hJtuox5X886~q^=KQ{{|E_}g(t`N1g7~t6_;(k?mlwppryzb>LHv6Q;wuZ{ z^J{q}R~5v+uONR-LHzp*;{Ag7BMagi3*yTQ;ujRe|6M`+qJsDj6vQtpi2qPj+rPIl@HPhC#=zSccpC$6W8iHJyp4gk zG4M79-p0V&82GP=fj@cg-|e?OSK@~g?>nO?;b(fACyWjGZTFOHF@VQrop^dtV(h3o z{(48&@TTxGrR8>x@jL1Sg=Ol>4O#d&g=PB5^;-BN3d`h^+hpMnC@fP?uFJyjQCKFP z+&T*%rm##qxmF7wtgy@(xs?{4ps-9ixkVP<-9T8TuUw;rUsPBoom`EDpHWz*oLr@a zpHNsPoLsquA5&N+vRtW!w<|1DPA*~L`xTZ6CpWT(h@<)ymgy$9)53QuER#)c$ihEV zSf;gHuZ6#>uuM0(O&0!Fg=MnIby@hU3d>ZJTW8@fD=ZUSuGPX{R9GgP+)4{yr?5;l zxkVQKCxvCA$u(MdmBKR3|fY;SVS*Q%bJO!tYU7 zCY0Pd3m>MiOeeWk3m>eoOeVRN7M`H6OeMKR7T%pEEE7qt(ZVk(EYnD?#=_4iER#sC za=iS~b%gCF+RuK4e)-X?^4BLMekw}Ko=rqnUNJLzjTM$2>mAu{`Nc0Y{+J53UEl{# z_-%g}X`GjiCZ5eUxgQ<+_^W!%-AL)Nsn^l&pVtxm2`_#$@rQa;k2X(*)t2iWRy$~H zr*~wlD&7)5$sbt$St{>O-{S`(e&6$-^7}@M{Nz@D+n(krR4^;9pk!?4Qt!yRz2ya8 z>)d*h6D>#2_uJ+krdL0BvU!pp&OMw!_7#RTdm$iho%lY&$@6J@ynU6=T|r_DPwhD~ z?yKG02!u1X*PabJqPf4Mm+5HkJLq%m{Mvc*&+@N*ZWspkqpw#~f-`@hu41M7$(5Q+-rdP+t?o=^9c)<_8ULi*j(nok$Y^K-u{C+=ZuNb9>zZpZec|s{haA!aD zni_Z^U$?)xm2!eSpCfLqhN$c+Wsd49=H03Kt;wx^P*+iv%>su~E__2uP4=NUWzic_ zre%L*Da{q<@&N^#_GZgE9TW_{@|@WAIT9?H4RP4^m=O>TzC=TQibOd z_M1q&Yl8X+zzbp&r#6dB`5n0w+?+>js_EB$Fd&%Am9dd1$ywjK{nd2!fOpdukXrv? z-S2z4$Pb2nuWpb3@{kIYW!nJD68F~YgJ4jp@l6HydhN3*UmMMR?PZ{n26|=6jNgj!Jk#jI)W-!*5KX#v_@0ALrU;@Zq9dZODm(eMDqfXJIlI#y&5yBn4(G{=#3ofsq zC;`&Bt-B{A?o`X^>0{~OM->}*wOVL&GY#k`0M-$2Xybij{4Sc>q@tATQaKvZEUEmP zDC+>ex#Di#z3F#Xw33!R(jcmX?#6*QQQ;{?=*;z-+RPXLbdlv0NXduecE#Sy# zj*dwK&wq%kfTt%9!y1FewOvUu!6QUesS4on$K&p`%*?=X)IFm}tGkk90Fc+oZw(FVg`XPj;^_dnyJDlo)m5w( ze<-n+2pf_*Q1dea-t=!*tmByttvLpbfVDWE7X7IBH-y#ltiPvaRk4$>>aTSyBoa$U z->w)TO39mfsx^&4miKgUWkp$CcxA;D(d!T~Cg+(*I$ol};Dy?@tx3ua(WTQ>2e=vJ z{mnuuI}C`mcdG9*?n?(x0o0-QzHD{esXnRo5<$i<9em#)T3Q#}Trr7AZ~BcDr972M z;O7gJ^UnW9D%0ZhQL6%+Twx^fLiSTHA*zDriUsMSODjt1t6%n_Idl>JIWJAm$|N`> zq~=3M>89q2GN0IT|0lu&za!P?2DQRZ@9TKCQQ-aSyiX`fdAINJs~`4msxD0=?o?JW zpt#wq+a1d$Kl}7wm*uVKC01xL(DPaZQ{y!ZQ#5YrIb=5*c+VRefj?43a{?p8Ys5tL#ptO8T4= zL+AtEF%x6(O2Hf%j6=$J7X;G^;>v|tD5{cY?N60cb!K@vH7fp#I_3xGRg~8Sucm?l zu~34H((|FSWBzP3(zYc}X6MGm_d{l%1LE4B6q4EdF8Iq|C$om+>rmQ_F{OR|uTq*2 z`X)*{6bjR%_=`V{jnR<>)#t%4(Wf9DKcrvzE)S=}ODif<|ItbhgoL=iuAlXPdP6@i zDCnmRBb<|6|7Uu)xv+OrTOES_8WXk0UAy^jbnWgpckMVMfETj6UvynF9-@DxUUZ83 z7frnJMFX56mk?M~05!S{zx;6b3jRl^Mm(1p^VXin@+bQQD5H`?R7rHR&C)M=laWei zHxfO%YeGWLKgZ7z_iV2ireY=hK2C_A?G++55*!EEOD|dFCz?q0$PYqmI*Z>7JdJ*M zW5pU`{E!LIo_AMl;F*qYGz~9JO$h;hNp&)T622%q1At%j&I3X}oL8|LEpvhO5Dr{v zkS|L|SFS70JwPoe#qB&2iMHKIul)*|ZreS`+aNxSPl(t}wEWCO&P6 z?G>fUOO`U8S`JDy8YTnaxD#firdjv7nzBcMT|Yw7jjL;S>>`(zndG`7&NW6H?OL96 zuqS(y3unJV>FBIvs%@ayhuwmCM#!b!jeA(v)`suOZ1*xBcVoVR`I(hQryk4!@mvxE z4<`xgxL;SP@wfwMfqOeJNON~82GA~X6=g33lyvZ-5jb;%fAq~2Lky^2bhFbE(4eWR zL@n)w?P+lY{0VuIoszl<-dGf!#=VuT< znzC)ieQHJ1qcK?ax)@oP=owAC=>@|8UFfm5JPLkPh=Qx*dNqa`vGFmymrCxG(SY)i zt0}v9Bt`+y#3+z*A{3Zn@>fydD<>!r$x1-a1F!p_phg*D6abCsD}Mt8Un)R>ie#?= zLP@)e^o0MPk5O>wT6@c*U>_>DMxCTxp=%|0)VL zDhDW7#1j_Y_%*8d_ETnU6i!G%0wd{ZC#Y~?lasy`Y!Xh7odTJ?J` zSKn=k`*QXB$TCh5cesl0)cPNy_%8XgXFRXQ9y6v;-ywBPuIl8@m`G?X&lL1|?qx!x zC|=UAu&?Q(=__&Rq90Xgq8>*K6^wI$QT_NlS4jP;D$g9!yoI*xN(1kO>;j&-yICHx zj)yF+ea`TZj%NJ>Z!tQgA`2ao4{E`L9cgbOi|3{G4g#U+i!EV+$sAZR4_!5Z0b2`X2>@yF1*=k`aquir60|_-wCHDpK+}} zNZ#BGmcse@hw*sw8QP5weMXPJA+p=mL=4|P%sN#g5R2@0xqf7S@T@WGn??1wY}QCQ zvMrR*PK!}9<3pAo1d;G}sUD>)mfqx&baq1fEk@w}ga!h4ot?p-@JnsM4)BAwg0aBplTN zc;lL>atR3#&0Ei0(Udoe>V1$f7!$`PJ)?=gU@!~`hwiYqJQDU1+t(K$VIN931We|U z@EccC_B*+8B61D)NDB*iN z>(I^1>NCIc*1oQ8Micv=Hk5#8@vEtYdqsCL#!{g|wvXr@rOLeAe$myGy*aDqOgouY zAhO40GyQvCuR|YP@r4@wGHzzLqE#7KN4F@hCnC@PefR^vjPxV+TzrhnbZ?ac<; z3)wC`qlx!EH7=#UD0IX<&!v#)>qx(qbTCIvLeBbvEF>Jm#=DeD%I(o@0kR_JbtT(P=Tu3WQR$?R|R zy!IZMe?N16?RmB5*IrP&a7*@jt7PKsPXhTqYl}~_0GRl7qV?PmKW}!=y=#jb;skqM zlDH(1yUi_DzDh!jhg1O`wDz6^ynf%#1M^+aJ^>8*o_*e-FnhJ@O7=sf&DcKUr5R({ z*-xs!6KnR?JinmkXTMEa1!;Q+;KYJt*KlF0m#Wo|DGU1vwEFCty?X~*SJ$3Xd$zNh zr-Mh>d{~wWuS+meZB zhSI;&;rc2be%MxNp|6Sl8Yue(Oa@nf9!YPIEK82Bhx~B8q`n{CA&G`nV~Bqv>E!lw z^0$6;V$zSUoXWPtqvP{exL)+@N0SbC(JL+Pr@T~h0m7QA_4$fzM_KJe@H9U>Fs>^dwyBG4*(CO$X?{~%sj_*u zw>7F{QJb$vRD7);ywW&-?2e7(%}!m+kc8{4?zlkPJ>_pMbX{F&f@Vz%OE}PEfHfuB zMw3^6)Q=j+X7uLwUBc69{DI;=Dvz<;-}3C<0)BW_4f`j{MG4lIS^s9j^^v%0P#k>N^LEbzmBsPXBE&&t$SEyKzZt{>#V1d*}`%Fj!sy+l*` zX$a#dbwF&P7#hT-3^t4LH@9%c-pEV6S?6;(t+o8jWuL-{3 zr1F>~!%{PBY-hC+ojL}?&yD_R&y3!s>tO7xtF_b*`u(Pv*Tc4TyP(q3O2n{zPK4}e zc{E>BRdmK!n%${##<5()osJIu_usL_C+jSf*&~{drryOvlsfBf(%1#OgU2OF{nt2l zd5Oe%K+M=3BKyW{cR!iJww)S%s5P8sl4zh!I|m|y%pbkAr!b-T(Opg`V3~UMV%9Ha zqs$(^b8JjzS=KXoVKVgt2GjG|Q@=JLL7zTTo(^6xvyb|9L`8NLWz<*g&3vr5!n^(z z+6k>i@EF)jb=JFS2BOKp2T)%W}28TXwUP5A`? zVO(w114s{8>Xl9@Ndeqa@9^To5x`5m^ZIMC!5s?H`brzBM_Pu{!7F~-@AlNTJ&hgf z1$J)z=+jBs-tH%NzgUYz-Uc-m5Ar&>?!iRvL2|f#f+p**Td+amdl@?4AEd)l_88_E zV>=lz&f4SLYz*%hT>`>{!T%(Oe_6^lIO56QNUVa zoU(NFrSSPXjnALYep|JnKHm6So_T3_R~MLsvKPRMqAc(-%0M~cc9#h^SmW4O2&URz zNqU(R7$w$iciMV(>AKm)w|MQp)<$w$KU3?rtDa|MPO5s*JNKkA-ohHF6?z) zg`vhCnh@OSDn`q4SsDrk^SIQjrcy|Srgg5B08LT zUFIckO&5X=45^Ry=+%ri8qVFw# z$jMbh7D`DK_$i(EBeF5b#k-tfJg>OVSg5ze$;bYdhXD00nvdIVI;^01WUdCnN3_F~ z-no+=WdtVm^5ow9abMk*mFC@}*AKfMw;44> z6Q}-K12JhEKw8t$%zjND}S33CS8}g&s%c~OAF@cX?g5KQ{PS1 z*}4u@ao0K{38yiJHbI7%f<5f9Ket%1@- zEV`&xYWT32pxX-Ov`bI%2r=T5xjmy#rtrROXwSOd?v zFZXG-!BgRhH7p!vk;xCLQsEZ`aw`0?3Gt@ugf&3APW?+2T_?)nVKY}#@wG}($B44t z6kVsD077xU>ZR41lH9@CC)`)8?hm(4o_)_T&3YTLPk`O^YCS*TMeEgibTWD_N%w-C z+Hg`UoY?+eMi1%`Kz{NWziF%Av@6v#1(nnIhqWK@?gGyvhVHKkWTw0O0nV13$z6o{ zW2`r1wqO0(RNJdec_XyvN41*o4raa^OikalmwqU0sEX!jYO)cGW;zsTzQcFbEkv2` z`dhZ=g+$z9(}7ZMP(q%16!c5rgyxRwp_t!yau^C*}1xAa-(v+tsx zcu)?1ph(N^>@>QMGapq?s%Soj1%-f?*4g*@BPjsjC;6}r>tJ*r);G9rtV|{EJvpfO zF63E86?^4Q?g1)e-2|=7*q*ze<$&`K^}{I@l(QvBEs5#m?sU^D_|ol2CAXgzO?hPR zx`cUcpYF~6o843IlKpiUrh0Slfi{=!<=_7lJq&Df^l;Pm|2OF2K>7(i43;~3D5LxT z$LQfMD*G=)5A*%t$vjP@g4g6bY?E+!!!T@@4y#y+H_!INm2m1Z7S}Z}a(AQT-Sn&< z&AGRPTyBw`8N*L%G<(R9Oa%kxB2|T(e{G0|FPT#8)NSV3z*BRsCiqJ$8iV@Q6gj%$ zm~U4M@|F(fZ}5ZqbxPTw6mRm9O%36X;;p{=HA-0L5^k#m7&32GLs{a2`t}rDiM>4I zlce`Wyf28~eco5b@Az$I7RB$=c$a&j@|RQJM!l2~xr|6Gv0jSyhp69g+d1M-zb6&^ zE*(6a4jQ_$(-_iJbh72>C5QIETqZxjHMXaU8nQ)X8mL$A@W*>d{IoUusfWR1*wB>@ z=WhtMs6k|l6S8}%AMtMdDY~|I`*8A+Ebe9qB2M?vE zKc5b7Gjv2VUnagw$xVNvscs?0*8rdK@afSJ$I2K;eWk=A!@AX{`We^~GNTkBMmvUy z`e0W>@F+53K1><74QM;i@R z7H5OBoGDjU)$!CGKg={L6!Z*|B^A{Tl#qQh@Abh84Z&~d$R+{}!SB=It=5kq(@Vs& zQ*1o}J{yux)>c36wSNiSuRe2M%X1Bxm#&_b3fo!*aNAXz(FPb70FS05jn=)4uA#B= zvyZs0`7WmkY`yBmFe4nNgU&21)CG~+lYR3gvNKA;boQB_X^bofm2XU!t7y9pWY1-F?6%a z54%Nubjb&-uq2P|FcCy*j0MFe@)$K@*h@!~D*dKDNYU|ek~Lq?GD<>F8G-4o{V;?r z1R74^A}>>XfN)m7L6*KUh7#-GgC#s=paBh~Bans>L^QLCwPaPPU%eYn`J?jGcasYT1h3S1w+tNgupdTh+;7Vz{kB&ocwgzOX@A9Qe*$)8bP}pa6$G!)BvtgN z6_u-481Bx=Sl^;g8H999#VCp`av@<)3#B@(KZ&fW0$XlySI*Y*HFffW_{q{35hcs zYn{dEOo&IBvvpNaR@g8o>oe4^`r$QbO{47ve_`~Hj?!Oie_~o}6HY|Tlj+ceT0`*b z?C0)>V4`DAc(-Qd7qZvgCsM*EoE}O!tKW15t-X-_d$NTsgSE^v&)I0-XwT{wgO`IL zuVMFy_k(Km)y#KbFimbHQu*$sGCx`}{F(fo>G>#=;x8(n&vLp!61QOu=z~MsD_W@- zl&JZty*7jT&3;k+IzKrWHnawluFEYK5>4;>1Rf}Pz0c&KGbJS%lV}tK?A6a^mwD~W zSRR=9GdY;5ew1~~trn4&1-hyf#u?PWI|@b`NZJUM>Ci;wX;JYresToDDgg-a=#W%8 zWilj`TzVn~?$UH}5P30#1ejv-!mr-bGR)wbyaXjJm4?Lf=!xOSNSH^`1Mi=swnR zgr*z-XuYBdHXq>D3CMK>%GQ>j1E>0y4kz9~-_oJgMP_Rw7+IR~mUB>aFxmDLTNB@b zp~!i@uz<7-O=q(#LIUP)b)|TS;sS-m6T4%!ixy_Y$C48x#NO{0u`4USn|R!S%?;Lp z0PCjlF!?4y#0?wL!I19+0(fGz72J{P3V-licvfY zdUJ=G`7Rn1uSnLRv4y5#q^G~Ypyse2Jemsb!>SVRKZs96&7*7zz#ziIqi)?j*z)^a zKYV;@G%qnqIg_VxZOHi{(+t*$Erd$U1A$hT#RE<`7;Jem*G_2`f&U@*$Z%pmUDM*7 zF))vB$Elgx@CF%*QsGym_ljVCszpIV zc)QftAT!U#^M*}v;!SJx;!W-mH>JXb(x}T^mW^?iYZ^&+qY;=wk_vC=ic5*+DIw+~ zR%$;X(KcYnKpvQ$mkLi=M!aS{UKjDIDU(;9*J)Pv6sh$#4Th(b^SaW-N|#^6tJCFw zoK*vPRsJb$SuehqilTbd_#f{iF&#X!j}|X|B|Dcq1NCy=Ok{u1FD?Gw>_2W{g!%xX zB(J=`E(^&jwo}bQf+5)^YZ*z7M<+oM6db0BBd(1r0;s-QU5B6qug{qR;H{)hzc2eK zlY_8HEGLLf$#~)vWpt=g z)lp=F10z17%`d0iQ|knz*hbYFWY*YY)Zdn6d2o94(GSRh3nkxh@?YWFe^|psG`c;^%1EEI?Ht8XI)MM%KQL!x~X?i7XqM&JcF~Vya%TwPI zf@!rSG$%`a)&!{eNjS7SAqc~6jXMi~R)wOg1$v3)F4hWT1Ft$~b?Z7_>Vuynm6s`F z(6h)MnQ1)I!SH~|1;aAt|Ax%3{NQ2EqmKGsYEXxMg@w!lD>CA@J%r|`1x$AhF<7mT zW|>C4q6+cqTb&~*PS*xK+9&*3C!y|@*9cB(ra zXqzM&=2eIhzOp;ioGZ%=k=^`LLsFcl)Zw(PXD5A1T%AHVtrOI3J)&N>Hgv4AcX{}{ zv3aBtu^q2&cExpG`#XddR6=~luKFXh1T)0BnL#1}H0tH4sm#0KX@H|wd1eYbHj$JL z%i^YM!$XiX>8432rnV;9OmbjL5)6nBrHgD4plQF&B#p#|@Zzo2t?URY)IFz6vat0s zk0GegiiW6!x!aaXQ1Nk?|BsUbX(Q?gi=nm^6f+1LZ*|F1jQqH&%qU^Cvz0}Nkm=ph zdl3B5Q%Q9bYP_#(t!W?e+6QPOUl#?+D5x^&YC|q%YD%_x?f;@&$S$fuI7rUS=$-LW zUPmgO#P-2ft#SLbYK;}67h4{Wl^6!tgif_}x_LV7wE_gPVpbxR+=Ygy$+-`&rSpoh z)tmVP63}{RnOc;qP4F0WAWU3>0o!QNj}EQ+52=!~QuxrYCekkZ+>D$!r}iusL_gjP+0>qutv;HK+xa(YC4_HSPy|;qrD)OPM360i z{t(ai9P3U8f5H(fyQ)V#an#2rY5DVXw(V|~IW`4ndRxv_%wjTxEjQMNUn$lwM>py5 zre#mgM#7eEO!Unqa9wtQy56w*8TU7AvNj4RX|)FVrk_){lSS{Lu=xhH(gQIg!svh= z38UvFh>pHO9J+8dOEdACN;3>ade=mkJ&oc-SU?iVs=xlDF59g>PuiA%mum6Bt1nH3 zXH?19=1*rWIr@I@`m?pg8Fng*ADu+*(IW5qT19Sq7V_E7jReR^5z)*8q{(@cnO#h$ zez7H&FBl9uOel~A$e2>hmMF$3r2>meG0lj-xkK zy{qMyjIW{B7RC<4t40OgiAfM;#B9sr*v|Hd;d&@{y7Cla=Nx8xurmXEq5(!C2bLrF z%Q*9=JJOOukshBPwk_iEndeTz{Yumfa;3b%{-6Ap78&dL~b^jSUA~T9$|;LN|r{`{>>w0uY=5UxnC>q_S^v)Z1e)~ z$fzyjQDEM1b6}!wcDdK?Y1LA}ywj z$|X}%O&Sh zn>HgVB{6oxg_?xuSTO@>HW8b)2F>MmAdd2*vk-&*ikq~CRae?k`_B!o(Cwu?Fmsy^T8sCA&I|7;;9ft?D!u` zp2L$4=V4R@bn#3l|3Q}g*~4%r(;%9IQ_p5)2+i~!SA)GQKczMu%s9T{Cm&)ffEiU2 zX>t#<>I;Am9bQnpi}vdt7-iCZ_)g8ehjx=9rRJx8BK%ueYw?3H0NMHN*@eLAMm5oN}W>lu(!UirsN^7{aR&3ApS!ZYMTa|-wQ4I3KwN+craYZ!v!)r zOitDXw`y|A{TnU~GhWJhVt8z6P%fzNB6q`draaS+@E7!x7;4-uP&CuoFRV7FAfaj} z&4OW$4kD8$a@%#hKQ7`lL+UkI&sbsu!DN1)O&ua4=1|=D{6LW9%^*XVK_XYl0suAA z9m=gY!9M9P3>NZ4WlL2?^jV^9`akAAryNc$ARH|t?d`VA6IXZ3GIVa;yGqm|R2G#8 zF%oEO)>DU^CLYagHSss4e@3rbz*MxLuAdT(`N>BaoN1P=yNpMz_hpdj;{PO_x3&bG_sh!d2K+$p`gVn&zvQ+VHfD_ZJ0!yy zb|CK1;FwuH%<7Sc;cunuZYi|&c5@zZ?re_J%Z z2Vmc}H#u|O+x8~gFzIjkzhG}V_B+yI{_ESD9{sof6ZWPWYWc5eZ`%58$@9nms=eu7 zKVhoa|Bk)s8k%{7y=mb_&Ao@#lkzw0O{*sVReMtrHN^I&X%`66x9v^;f3Y`}eCus{ z)8Dc;&HNYaO^^SJ^t}HidsF@_0=JlRUg_HB24yzG=LePTij_K@v`lB0SYkF~Y$v#q z-~zp@4sVb`$VEG5X$$2AB+viwlxcdwH%HDu^6d{#!4*h%UW|N029>Q8SwqR}559?A zrH&&BSVd1Ff8G%vU!EzrUx(?6#=JidcWTI+=L5DqcV)#i^W~|FKFg*thqD`+?(w55 z#!inW{f2sx0wX>r0=VQ&o>Fq>Ne4ID@dbfV6+83Diw9RjK}u|m4i+tHh(4+t@8z3w z`jE6XToJiVChevA<<{>KMu@R{(=+UAxbqV7(^q?4w3n6(3fD$k(@)_|KbT@mD0tA_ z9e}%FN`5?K*6y^w?T>y?TtPc{t8kI7+kI}(O(6F^d!_d6+@9};z+8$8YUO`YkGz~Z z^_vpdIOA7kPms@FAS(dpC$g84ld+pufkl_QAj)FrSu}6<7|v(Y@|1flXKA{qxuOI> zTLHtIV(MmJSW)S<>v*mFVdhm-Wwy7p>d;tC_TM_C&0bki&fe(&Ah7Sk{$qWOmwAnC z8@%!ULMe`&&pV-v4Z{;k8mf0RMCX*U;j<-O{V0$A`jSVy_M5c(Mm5tWcx&5umoxVE zz5A>3zn)Z;V#A949P>H&lpL^A)z7fM%FV9}y!O{IL;2yP3U)x=K?jR%S8`aU=iF|s~dsTxq=$st|Hx|yNLUheD3ZNA40rr8Z^TK!B$4s(V>og zaC1l7(|d4*P-B8@=knoyzR4uWAT*19kJn=3HIEd4-~Rbl+$hP`%8jKsE$yE>-DherY;NSAooQ zRY|(~LH0h(KgSU=ZpqDw5#IY!$=>>dewnTYlJ&i*YUuBl{`!N4>f8Ig_K#@vMC3)@ z+V}IG)-c<#gZw^xHFSQ&C*yMlTj1Nd6d2&XlfIUn>FO&he6RgC(D`XmdKM=N%!_7F zJ1s-nzNvdXk^3pB@p?S_fO;7n^L6g36K($bpN;PF#9mzS`8l9)4kS3wZV8U*{XEEe zAEF;}^d1#22)}N$4%G)oT+7{NHX{Tt6dbW!Mw8?IDqIZN1r?R;ej@8rdUyM>Nst|-@;-Z#jLO_q40nmwnY3J&}8dZTUIQRznNY)1P5iPR_muq@l_(Uc*(zlg<`03A>v?c~+nJ1XzBr*rp{+j(0& z!M>e)yA!V^VaX=C@NOFcb)!b@9uT*?XWx!IncIv9N`Cwb&m+bvK$)T5&LdLGMI2oI z>4=T+?beL*3&sI@$RdBNkp<3MWs1hNa5E{6WZXt&c!NlRgiR!L*{gGg3Qt+hhLo>T z;VDSm`i(qME#fWjQyPitB8o||zLjSU&ow+N$+Fs&n#QZ_O2n4)s;z1o*{Md_dfDLJ z=?)G)q4SN|Rkuj{xF>tUS7Z$40N`G=qi*^r=d53|bJob^SR6|fPb63yoq^ZkRhv>x zFQ>!vyOJEjj(v%H40`YOmxKD7@sZ+Uo+kifM01pca5#S>LG5aDAwS0Y1$s+9Z%)5n z{UEdc&pC!&$@4WlBq~Y8o$%M`qE2(P2%-crsU!{w^EaoGud^Si4yqKJh>g7ZT)X7c zHLs(OQ&_D@uLCvZ>7s+U6=i-aez2v=6JE7ujU6dq+uS^Y;~To8GNp36623x#bK}%i zOAoU_`nx@x$fNu;ax|dMcxMdZ_R$S0Bq=jI7|+Q1?v5a`ZnRD5peIY;$rD)~T&AgI zSm_!XKiCl_xf%;m)ekee6ZFM9H1}`uIS!TzqcuQx z3EI_2BTjWC4Pn%({zOwhiUY~n>?eQXpSe#4I&RH=l}RO>|1;bf%OT@dTpHJCJ`h4+ zS99iE>YX$7owqO{geBn&U1iZU#1%Z=+5_Zc6aCYeZdz(TOaWBLV0fwb0$wZ7CF-g! z;fl{;`PL`4?eR(|MI$G+6w*LFCdOD05!}-Am4XwJ*R2X1h^BCzRA-(c zPm8#pD%l(3s8#idEQCB<@B11!Vdd_;h&?49ZrPdpIe;JnBongl`m#d~24=|==g?>z z5Th$C*Tx@GEwncZL^`nLPP4+egBD?Dp5*zD=n*>8NZIT|ppz$ES zY0;HmD$f3kW!B*!Hy)wYocntU1L#hB=!Do~ew2QI>n}Ovj2~LCCr@8E6q`Q?E*^MY zY{TAojg@g{7;r8&DD2=a2Q0bFN_Y*A12wh5%vMK816QFu#s{;kz>Mv<7T&^1B92lj ze{DE(ou=@hk~o}du6jQA6T{@hfBmvFrXu{fV1@?bau@RlmoPbOz0jMhAe8sV$RGZ( zCGrLqr%W@;OlVXky!P#WBJn40MX5KvqZOEWUCn#XI`{6Ed(-W77V(QJz3I1Za=qNF z$I*7O29@Z|2m6m(N4l8eyDP=08CA`#C5zN-$RyakQj>q?rRF()xVpp-8>{@I8!L^b zkh+6XR-!o_656(I<*I<4Hxb8-Y2~Q+)2cXZTQFYZGASg~c&_dr@I&9HW~Slpou+22 ztjSlNPeN{S1HXsu|mzc8$3hkJTuJ!(##DkCj$J5 zm2ZiMkGN{$%wGG~tQvPKDpy1WJ&gwSSaXBJ!^%o`{HkZQs%QQ+V5Nu_;Fv?|*0>Jy zjAjScT25CHkXE@SN^lSz|o$^#ef%*2+LaBwKjh5E4PLJ?g<&9CV>9mDPpcx)L~X&09wr z^V0WhB4FgmL*i=d=Sj=ri@unwZd*w^Q15EP>S?Pf+T~EQks>4v(Il71t)#NMHYqB+ zoVobc5^FoYJ?d+%F7Kd~Y^otYnro)l^4JAptUedX6Ba&ZL>e{NL8q+&(2giYzk6-$ zA~^$7f2F}cxhG-4?pEdD{A@aGDyJ^UJgl_7+)<+k%9ks)(h$^CM(e{aW|_ky`_dd! zsH^Z8genz@6=X%(dvNOl3UJv5#spSzp&25`lnVYZ9vK-ut7LF%jmw?Fsfw#Cj3r#c z8iC549VEmRuM-N#D^A3%r-CQlAj0{C3ku6)di`KHPxC}}GA zolcZ-AdTYLKi^0s%YV}@{Ky?ii=su!8+2qxQJ{it&W#!+lEZKoGiZu_Scz{s=Z&+s ze{pO~PQ4SjJ{MZBftj(rA@~zh;3#k`^^WZkEy*#5VE)9RXn={>4aQbX1<}02#)1wV z5#Z*b!)Sj{t)Zp!x=6Ix_l!(9$Vl!5>FBk@a{y3Z^?F5lRH5<&9h*qxU~LD)Clc69 z5My8p8O-%03j_;AaGxd^`4l5|qw+988_9Ky64`*}&&fJVehHsz|K;D3z09Sgv?jp% zDKBbDPora$jwQ)Xqcx*x+MLjkd_cFN7z&IWxhu>(>jCjM0+C~7>FJL`_Zw)vA(}Zw z9^OGmrSU}fGFm)6n)$lRIiQw-qmmXW*N}YGfzUl-Wt*pzkyz>yb=JFQjX>ir5QE7$ z3z4^o-Zn(dQ_%9d%gKPcAl7RL9w%`DiK%UT;Iez8b@sQZwg=FrUX+cN3ae-clNiZz zaAhf!jxG?ktt+&&hC+-%iTbOPOr3&^1==H=W+Y_%==r;`77wMiJwrbiP=M;GIzbs= zNZ|zz;xH3;i~UYqUmFl;5`=7W`A;ncT!H%@&KgPdN z(z>jQ&Xww1@G6xpvp3h%o)K#1JhPU1vhP7OtF4iqk-fu4&2+41lo(XG&7`Bj+OWv6 zUDy2r@JgaFI>DG( zq{^}B^AEYz;|l^lgIMC2W|$ytx+5S#N2|fd^#|9( zGp!B5ld0gIXFqG}GuTa8lbx>hPHUZzHQ8xRCOcg_oz_mW(`pMlt%+o(Dh)d~^0&HE z9r4ya&k8x{w0=f&KlpPt*sgA8aN|=hp=&8B-q2Px&1>Jvs$esVF$in!%a7namPs>i z**O`xaj6b0c5OY18w)aO#cMYc0q0z44Ew~788^;!Enrb6K4Qtr8t#33$eKYAY#f~% z)FXd(JDQg)Wl@DK@evND==8&YU;QXsEj1-Oy!JCIRnQ6f=p49xH>dRG5(!h4QN25< z_xL(&sdM6EdUH5S(#vkkP|Gt=og_P6_X4i@$UF!|nQ4H))WDW{$+wGkF`Od=hkSVB+^O4WAIi@ep-r4gm_4W{tj~ zIQwxB$;lGDMQXz$>R)>U+)I8{LPs^SIPak~EdUf&-y3)U=&T3OYtzAPiv(cuaSrXT zAtw^OR9uyO72X*psX-fboe9N-oi*g3U){c{j_S5Bb##vCJ?va2c#tO+vKigymKED0 z=^3J)b$F_(J7C9E)~(tx2Mwu2)12$Hy0+JuKZFHd;omNft)9RF_c)Ah-r55x%#q7! zpeIW{sNf(kGg&Ln=<+hIW%`AaS$0YoQE?E_C8tN}gV?v2VoaW{=IVgr$=>?RX0EO1hN09}CN6MgwD1#d|q9@e}^Au9VS)%@xKou_^A#PMvBl0T~;jFylt2TeOfa zx=k83q+H@B-Gv23ozgF;vxeEx<(+Lq=(Qh1uN+n7PPD=A&Pp_5d~m{$v%n?~*#^5e zTX~(Sf0?IXjdbv8wzpO7^hmo-U_y{REzBt7x5+FphluQJ*Ep;5J>(5w8aANfjczkH zN3~{dt_>clO+H$e9I36|>P35`9f$8k0q=#E^qpIlQlcvEsO>f4I)TMY!XmymOcn^! zgkM{a7Dvn|JmcN zq0$W1$;WkFMSKedMm3Rhbi_}Xo(7dA=(OpHc~A0!i3Gb=OeWOQYV7MKG^Syrd|E+j z+fHMTxFWUfIVpOn;8%2`m0B>AzSj>hePy|=bqXiPqgJ)l_Iq@d%qG{U4Y=;sEs9DM zgT=Q@&!P^SIM54)fS{wC$FnIaR#y#^Ndq`tcDo_6lx7zUF&$Pgo91Guu~xLwyxhBstgIqh2Sj{vzTlu1=U5$cQYdgVAy~R76MI zK^DVFG;>e%PZQ9H?k!V>pj!lMH?Gc{?ACRuXigvT5-Qv@HhF{wmB(*-r~1BHL|4?& z$^%}))>dqCq9LlAs1@HtEYn*ZPpbmv&CiaTtn zql-GlEj#zQ{Tz|n3QH62g{6Pj@@t012BJDrmz(*71J}Qo9*8aT-1INtYFUmaAK2!4 z&cwfyrdS#Y?xgAb9Bvk&RolsbFY{q0$J`ktXa8~)d2pW#bLRj5oo$ zcfvY*y2f&R!U7cTWVE^J`B>Se#*_w^B+P zK5jH2LIJ7`_K23*quWGhFw91|Up`Y?JB{ z759iT{iI+jM!ehliNZEU$T$@N(T4f_iFP$Jtjbw)OGHNtN_pMrUdwq+=r!zIX?c3G zs)Gi?jIU~f&Kd`pmOFwR32bj%E1xOT8>C?sxP?j3S#HU!vN9!li%vm%%G9`5nWU;* z?gcysGQy#WL~RUYDv1j-GK=u8W+T&~Nm)eq*+aE2%W%o4)PARPg7eJZ9c6NCHF;2@ z?Yo-HUn;K=c@2!EqJ_xB)xzfn>rUiWM<(t`EUTZvdOccZJ$9Fxj4Ojx6hK|vOzo(7 z>p+Y~9Bs>%i>c@zQNM5;clsW87w|!_R8(7r+QePulC=F^`+B&>6z(>w98LUMVr(Bo zz6|Ky{Yjh+Dww3TiTD`bH=AuHhvq5lW*loZgFc#%0?Vs;NwJ{dfAlH9 zkSKYX5j&3?AEXKon|YCoZh}{Ih1Ah@%g|W2hK1?jY%Y+3!-r}c{b=g(T;kHmkZGW@ z{|#$tof{)<`s%xp!5Ne2M>KaWH`e8s?62GMd~5cx7T|cp8g=dxG9o|N9hYDz51Y!J-cnV<)n+R<(m)->}v zzCH0(D8+~&7HYUhKqe0}V8djG7mGiRT6c)IHYd&u&l#r?Uo_HotcJ030qx*?4c1)?kyJo`ad@}$Qgw6ArCotunAWy@-RP_V+Vd0p?KJ}|w4yUS_eQ)WlJ7}O* z*Tt64P}K&7-}VB#_hS>h>klCkfGYvbe6&)*FB$w|xoFMIyJ&3{N~)cU*04yRr&JxU zwyHGtoof_M4yUwhtNRFbqF)Q7EF@(J-Ks@KH1UEKjTd)8zofMc&YKNvAW>xQQJ>dt zeWr$bUi8kz`G;Hm?0qsQ;$kWh?Jxuua%a(bkSpQ?3xg!RZR~$RwCJQIHm04FWZ{AU zSVNImeAeEjGVAK2v$zO$ySMh8a40Q~Du?7`kvKM*U(yhrUse}%IG*U)U=?&2H)5Y| zU^5rWH#ylcqE3g=MnbFzL1Gn|5tV8bQR(*UV}41;lNGYEirw!MaB0H0U%HQ!tYwwE zuax{4G5PhSbGR@$d4$QyRP`hK%E=E4_gfH?9}>#z?q%hKr&V4~_Bc6d*0ee&O1#Vk zPEHEqx-jmuP0H~p2cg_?D9qSpXnh9c^fCftn;OAbfiQLAcFgX;%C@|KSnZHl70b#; zW7#n{eA?J?7Yw%u%;@FT>*Jv%@i^6#lb1$B0cOu?nsNi(DAfmvVy5gBQ_98U_aIec zY&U4JB;%E>BbAR1eNCSgi)Ouxn~X#?(V=@pS<%$j>@oLs`|6k-wQ!%Vv-=hhITIfs zrFMQ}_SLg+FXB6i!uJ^0YU<-RxCJ481Ni{vpwC?FfIlB<*-%-;TO!Dg{sErB* z_v1CQ?HN2QiuaD+%mWz~ttK?b4YlC;Jm|9w)jd$$gK}70y9RN<@l3v(+`WdoaTD$) z{nt$Mrw^r~D<2)@Dj`Ru<69Gq|B$Oq@>ib<@=HJ+-&);i;mB-y{g07m1PM2)M z$MilVTy4pq*WM`vvzUkNShn3nh#oH>B&$rX&0p`(-#L8FLpN0|7?Akl?hAcUuU~eU zs8I}D9SNA`GM3v9A<|b80QWc_#&?@&`H@w|$mW02IuhgwTE34X-Uh}-6pK&P;kFk} za!(muPY0K+^QOnAJy%519#v5lCFRFAzFZl#<|cQ@C5CSica)Pcz7$6JTh)?00?p7( z8znA(kJbs~TR<`8OHd2}7cZXFA@WKULV{kkh7_%l=z-{Ye7$1#qz}|*hBPI^0g}a-U)j) zdtRSBEt-T!v%W(^hMlTtoPa++%@2?FGF-|85zjG?>2Y&pbi`~9W^kMHm9s}qkLDd- z%D$Ot(A7KA(GhmNAq3vf#PI%fwW(qliW2m#J{WRt)%{4vVcJV!5K8euRb8@F-_GSx zy|hP_@8>=jGu@`Ecc`j#wKYKDE%hajdF^=4Y5G*74Z$FmOQ-Ft4UHK!lFAZ+oxF|v+f=Q-v+jq289ak*L0OA&qy7rPgosM>BjwXKg zvI)3P&U`f{H7NkWE}Pt|vL~bBG4H!&UXxKP_14fpU9^B(hB`Ia)K@n!T36kvY2UkX z3)=KPx;R<|A0D!_>kBFIRu zgwUrLL7AYYe~_VZvWzQx-b*N!Wex0gC$~AZqKj5R+6Xjh_r)b8-SGeJgBp5E?Gm5r zbP~1ABwfu&15@PizEaL>KNg(DlCFzay0=%-hMVP~- zvNIpDR%njT5$&}{m@hac6ua1|&kdn2b}}Kt@=nm__lPVLsWS_fFjt=|D zS45Mh-0Oz(XLBd%d*Drv=Dw_f3Uw!VtLuQ4dhm?nkwjP(osx7MlnSqx30f+_MmLFV zrX{S(w`eHY^b?7|*Ro@#n;yrF_WdIeiI#fr=aZb|ki9`u8osb8Jg(!5;O;s~>gQPq z6>U`AMyMeep0Pc(Ez8!fUE4l$vebveSSzFXb2^zFce3ajwG_LkwYp34-KgTrM4Y-v ztF)LavgW-9D-c(Xvh75VaDlCK6c+=1I6UMxIf32wd{R5s?ZqEaN1TNu*yVgIMVRh@fJd4^pM5C$j zK*;=wjGAIq2cT^rmtCJeL!Y>~H9?1Ty*-0%swY$84<1H(9PV}qg7dpV+d1{7*SD&c zGDE=RTgxS44!3RR;QURbu2X6isl<-zv3GKBb+IKbRx_gVX6Z3`2LTI3Lo=^pMeoG+ zx>!w{iXC*ZLy#PKrE4fwEKT05t9KZ}P^{)g)!<^K6o8azN)Z>t22E#3C1Jr*@6vwi z>?IAWrm`)dBs?S4Ar)QU3myqgqfJ7Zr759X6dPTPZREI<4DggR0BSSs0KF%>yheLc$w` z3p+nHxa!Gt_4aG@nb)LVK7hgr@0Cv4AwuKS)}Zg5g6PrVKKKJ(;qr3xn(~{5;e;{~ zvMxt2GH(DjMAwDysSDnNiyWgDbT$gnII*{1MZ0JMJ|9xSVam`zALjKjwYYT^jhW*8gthlLI?L}Wu${2F^Ozt$asYJ&`#hGya;zcqB2>w=A+`8SjYHO|euypbnT}`Ta z;O91>a#qeQ^w}(}8yq#;&`_;D1-bSacn&bv(Bs6_M}nVea2*wD-Q=2Q9DTY zYyI9?LfvNP{FvcLc1~G5&CZF;daLz&dUl6;?qwFk7?{QcD9W<+ll5L~Q^Q%Fs`XLl z+OdC^3LlHAbda}!y5${~(0FxEpT*Bu-vxbk)8k1DZ_Wm7hBq#_JlQv%vjypUqSN&0 z`H%Tc>|6Krf4`9X4jQ@ z);^Dp_>p+R{KlGwq>={khp|gB<(07SxS+egi0vF z>rnnx9}JGyzwSF-(4c`jU?-($S#ola?Ae8%6`4(}q6bi@kYv};AAqjxuAz76s|t_I zPT>ni5T^1lc#5|#wf)LxxNW9P&o+dZX;yG^4?V_YWy~&6Gp>-XpRZ9+`Eo#kB5Ht*ugJEF`0KWh8+%O6)2WExn<*-qcr-v!SY2_J4H+(` z9<_wn=+Fa5G($!yVW#54EqqB5vxS=B0MV?8MAe?tn0@bwx*X&Ec_Tj5!BO13-&87G zLLy)qX%55jb)ti-ry`IVoj{Vs41x5Hg(8Ta5@ubO?7QT3NF0)1xWFk1oNmn95N3TG zI3RfAO{QDrWa+!f$r#KD)9brPHvK}AYN4*UL@3j0Q1Aw|0*cejOr{c-sbvE>@+wAx@)Wdrmn_pLPw-ah59BK2 zq4tCuzM&=5sGhx=2kJqIG7OUeI@XZEDZSJZ6FM2DQAA8bed04^cO2#Jhs7V#^+D*IHw@w)I5a*icG|Fj6Ocbut}+o)Nay#UaaWMFpJMx!W(7*P~bpv+rqXBuJyjF;K@K7(CQ zFyEKaJf=Wq#43h1_Fao+-YZJQ6;2pz;4u97=UfC6j&nABMs){Fpo{7O`kufX9+enI z`I&_0)dPq^Zl~jmo2j;Yli6>aPsyTN6QaDL&P8A&J^MC+-LeB`Xn-Lgvn4)59XsSrP+_soD&pd-5OCO-x23Y;7y&VN7yM= z8?%E^vZ&J{>>$`8^GwX^1(9fujxeLCC8ki302Av1*emKHFRyc3M z4vu$CF6=W|YI$Q6G4MZldmH$;t1ACLlT0DS)^92W3ZhmWHI*VM7R}fe6Bu9yCJ>}Z z&pQwO~<@uHwqNxOCTobr&>gX%mXHDFqsy%kzARV0dhJ zD!=#V-20tO+Tz3hAM%3E_j|wh;oNi2J@?#m&OO)kn?Ma@YQs9qY`6ZoHT8X8RsUzb z{T1P9{4@MmI6Br;lj`j7?1|Oq$If`y5Y4f-F5pq~r9yDy zZ8inlSeLb37&nAYJ2)!db5V7=H{L@}B|K^?+g@b+T*Y^&uAuWaGw@l#jP@jd>_&Y6 z6;p-0KvazFJCf+QKpXe-f`iz~wqQ5x*7XMtpxidwy6ddq=C)7Kf`L)h!~uS5)aJ#p5uzJSRa!B~FLFCCcdH3-|6h~Z>K2XYtgARs2&w%OKYt0S zeT}JGMrz;2A;c5VpCPrYXs(RZE<8(e_8Pbqd*jZx$44iLpT`*jBef*F!aOPQE)h8v2a4c?sT zLnx!o?E(W@9Z`Gg*uG-q!1I@@CuzewS|F*4<}%#9%0&$${uVDzm9p0S{|JjxJyO`L zZz|ka{Sp@uk!{-RC~~!1jvuXmr`Ab#i-LV4o4n6jJoXuO$fq3-P;(B3RjAFjkAlag zJfvd}WnvGfV-GSA#O086-NpR*J$Mv8bdZ4`_6~2K3Dp&*-|5ur#TSY(jp8RZepyoQ ze!XU*F(wkZd7sU8T&y##c3R0ifz#|A&NB&58Ac{)-d#cAdk@osKOfnM{PmgCb*;+z)i^p>fQ#xn=)Yp*J{ygYxsia!O~Z~=?`RLh2T=|- z#dce6*(PkS4_kKrCZ-h6;`mey_aCxmh7A&rzJid9)bwM5(%^WG7NM6$ff&6GTcj7m zD<4oHGfYHO4d1VWVlbvkeqw~Zn@?c{*k)!Oik2O1?A7yO7}?n7Z0ugD;(Z?P7%HNq z9l;OQkL9us^ERr+*{BoM*Npd5VPUprjMul@kDQd;4IgN=p;F)2o$k9U`fn8*6N4($gV{MoH^S(0Sv- z>b;YbaH!=I4$TXwT7$6#OqV>6!ha;|UMgRWpj5t{c(vI-Imo6o8(wB+?5*pFeXjq5nF9a-e)Gsu@9y? z?+!W_nA~u^n$My~5^oJIZza)AS3K;`Q(%vrdVse_ZakhjHNM&oRLr=35-4eZ5F^`8 z4M5T=Qmm2dYiSRLi93>ppCBV#3L<@4>QRttcP3h#5eTt`ob3J!63tl~dz!Uw&$?$e z5l7y28nDkiBxeUch1fvJ0JtHVw}w2wygb*+h{= ziku6GyX%=U5{4qP$yiBWs1eO-;w&bOW-*Zmc?*G$=)fINrmedJxLcX{xLLl@2MoV8VP6ezZFeoxyDnG_8dK>Io}BCI%Zx`>)C(M z`C~y&uoacR>@=8O12se4!Vp^-N9#u5;Xf3q9{*gv;J5gYx4m%L6ON6;Fi$_rQ#-`! z=EN}>`I~LcOcW07pj@PQbKX48JkN-B)2Os_nb!CcG(<(gkYjB;fNHxnRv76)jjid~ z*mg7lvkqeH7}097($FCcKK|I!PLXdM{8)y+(~ut{u=eM%pQ^wta`5ai&kzEKdJ4l- z(CA~Ipe~!tMgxn3KLR)TAH|oxj5)Gq)&&#@4z`mSycsu?yXJH6L@TF*T1i?=mGJoVZK23+9QA4#PwwcX?^1V3HPDq~G9Yh>9blOu?xz z3e_~8E|}gAn+%QyJ4LP9wAy|Jb|5>8MQF5XiKOm)Hvs8pQmSBr>F1~TY?DU7t3?e_ zOcRr+6nAvRh7;k1|Ln6l7C;}Y@|GIF?q$waa0>=NmBXviW8(} zY1jqb-uI%Y^NvxgsEhuPw-b3RrZ?DP+L#~b;-jE=Akf$YET-4=sjTx&FT|JRF$GL2 zx5DsEGM63dTfRe9BnLB!VTgAXs6ok~Q4*bGn?#tuTuKk{OcX^%C+gHGPC!$59;}Rk z(CngaN0t-JU`wjlC#eJak?Ps&tDGiO?9aZt^L5eLx|x@s+&cZoAji(vv5WeGGykX( zc>U9ms&V&{0}EV!Hml$sXY4fVv3Bh9j2+&n*rN$=IipM2#Ndeth@2o&l$5;Tgw6+p z&PHl2J5{%y^LVA~)kqQ_47xlsS$HD1cBux3C*g3i;BqV7qYSd@% zetH;;6%!M&_KpJI{urGID*h^Hn{3!IWh=t*<0ms1_?`Gebp4M?I6m9U6ixz$W+;-a za_*9Lh|a0~M<1fo;Bl3kh79?GPOv6q^0#R-;V(b1p}xWdM=rebWp>~f5qD*7LXs=~Ax-({ zM6Gs#C$<1!&@~IKAv3qZXzq@B{cwm@%7?-@wr|EK-EmrO7h`ad0Sl*b`x`_2#)rKa z*vnZI>edo~XVhbDt%Nl=Gw7;|U4lebRhor?lr zvQGAaC-sXH^mo(&k-EnkI3fN@c&z0xzY>o|MA&=F+)FBjI*oeCzvSug3j?aw^cvw$ z|7hzrYnjc#UZYw@OOw+$s%?TaYFHM-zk7<3y{5AlUk^Kftxo*~}rmCw&(JE%1Res;v{%|<{ z-V$=?_;Xil-g(F9$BOkQ?gKd+$OCd9%ZlRuU@!bMVC)OOKO|%EwG&EJcsJt`mj8+G zxrwWa>uDu?rW@#C${-{wx82!Ws&QIk$FC5lTUc?-kEL3aQ<239l-@`_c`ovoxw8Ke z!}Bq1Cz&bI?35_EHif4?s+zkRC^5=Ypp}f~DKJs{v~<-Ss?!_>oJdf^X(#6|@HqZJ z!LnVCQx6t2dw z+J2iVp>2dLGkgK_&BA;EyoPIjCnyYQ3Qvp(i%$)mL0pwRS{+Kh$wFE82>G}bkoQ5X z@#?L|;MD_0r2p)QR5~M*RR7_jaGA>BLMYDYxeTh8VLY7>A~pFXu&WhMSg8k)n5j8= z^$MD4e>D8{J#?Wk?miqO?u-ahJ8qa^$+gS;7uufS_1=~Wrdpg6H6 z-OK!ti9|aA=VKE7n+RLizrR5{s1ldHBoSww^6_^``r7oa-E^<3TXDvB^#?x&J7(6A zeSMnj0Kc=G@4ovHXXs!9EgmAzTKSv&ptm8o?Om)qK5`moro(_@*qEwpDJJ5LdfbXF z_*OAw1yt*D!2*e2GF&|LIMT3Rs#4)&=j2iNz&=Hxyj2ng&xpf{+I+39N{%U0Jpp^l z>+NZ@dgn*=R^S|0hG$nVSnLB=`twcv_-TrH5Bt134VHVr?_!8}u+HC^F8v%hcm+Xv ziMkiu!cnO`^_md14hPK$mcOoH+Ec%IF(x{Am+3bVVq7c)^gP7rj1QR#^OVBjagP0X zHRs9f+NA@PbcVbnG>G;68O`S3e4H^Xv`xb8cTat2qg0xWe0M5Mrt9aWx|tYhG}mhd z-czMHN?aSI(qxlfrqXl)hxb-#PHA*1O^}?1oV{lAK(0b%ejPKYuX5dt_6^KbDV>xR zeI|wv&A$!9emfK1_6q5RnF_z-PRokvn1?BJ>=XqXy@{o;lYwe~Jlu%vz*5&O!tm?j z9u@2lm#CDDrOJ7u`gIX(a16)o%w1*M!v(4gPZ289pYDX#H1U&R6_9JTa5@Hy?>sEN zkofOxat9|27eD+(3XA4X)c1tK4DYNwG;zp^tDfbD%w2UDOE&jgdii;M38?U^>3dc%bzc?y+EsA6DtLmqJ2QT;?@A3wui5sek#y08 z;%93fTI3WuGBK{joo*&v(L!NCB}&M<*Qr~Kd1X4bS8czoIrsNpR8aeWjV})b4;fWzJ zOfbU@{9vhY#G=kmmLrsPykrNT|?)y=zwNsG;rn|OH|GoTAs0Q^D-J_y$UKR%4Q zc7A_;%;3;eIQ#&#KOdl^F*URahIk0e+3JJkZ_vNJ7}+Tw&`H>Frcz{wX=WI#7UP-< z3&&xXnaG|oRlzY>3qjMA>_w?Q%QC7z91ADfXmCQ3=o9TF&XJV&rHK(ePO(;4O zc3^A9ui@cL>nl3 z)gC#mnul|ybq6QRtaHw_RuciHLKBg+=b3QO@tFf{lRr!j2*pGaXE#KUt_NGYImoJZhckgWE&oQEP|c*(_w-Srb^s>qKZ?%~NHk zVlzmE7|fDBh5#PuVwjVFkNuPc=Nta~3@C(TD5D$csl zyjK3T7JNYF1x@g!XXDAl0s|FhT7wj)O3`U9uFJGys`DPUUXaDXHsyw_xb$<v?%EH`}u!H`}vlv)h&m zQ%n{gMfWvw8r1P?nMoEMZd5Pjh!?yX|2u||Z!rLRyhVnQ`~(mZZF%gE9?Ly#T}DKwqjy}u7f>;Yvq3LQsp{dBDb{?q)GOh7d{zddk(Aqyh0EB0+>vs9 ze#eeW9UFFps{=E!S0G18kQh^T?@PWdu;NA=bzRFQPKAXcep+E+9J{cyI6H0`?c))H ztJ%OfPb8#R?b$i!A)=K)OUM`4h}zuC6RDSzaD3B3Wu8b;;iQv&BTuB&WZT0NX?nD8 z-&7{$I#;BJK$N81Z1QR~+IHBV^g%Lgm4w^{(?$uo-@0=TA@|k>YLu5)>mf{n)C26z zo#iCgzpsr>DnIjb#bD?>Q(JepErNmC{4V)3g_(z;$&XZ+9XeZB;2dl?o3-6`y8Tl1 zWs|SqVDlRGLGQQ5=xc?7@Ej5N(3J5@wM>Ch&73Ae3uBTNeaaUjfAq+LI_o1}<9lo? zOw&zh7ZF}hlYE4haec&!|9(m&<1ny*#M&{%n9A$Y_r|&Wag;GE8 zC%49bEUm^SBm`z#*_fET&^m6p!~F;N+3GOL-Wlzts)%hhhqyO|-qfAmh#WQKHCe&=)o(T}=bZwzke4L=EK*@`RGk!F&!?)pndM6aW)yA2X%y=|nB>cx-W zWbG#1>{D*X6*{O4P&J9X{dOmXqlMA$4X-AApKU3T1r zHV5T)-01xFUt-T4<@5MKd^f~v3T+><9V_ZPd5?%el^JwRDld$A|B=#mtVeZ#zT~Ci zyJ*Tr_R>xujtshGQBiHh&sN=`EdaF9fTG#uO?rcF-VlqHC!&VX;+_1pmR!N??P70m zHvU+fDSytCTUO}J_NT+K6f%MFmyYJ@OFOmjaI7m(Rs#eEiy8m?R0(F~+kY%jZ2zk) zP`POV-UktqwbE_=`!0N(&3|y^r|~$<6wX2c@N#hFhs^!ZhdDh>7AT!wn@2(DPTGU& zGR*)RV1Jx7GW=}A0`(9YPMb@bZbxXxg+D43dtXTvX_{7$<8*H`3d3{(bIs>4^0HkU zK-<%2c?r33A5E&=IdLv$>}Iss$kQv_4m6|Mp9rtT(*t+EB5$V^(6~(5O!0xJsr^)v zP_JlaEo{EgQMch`hOMU9Z_bjh2xAN5Q&eB`BUGz|=8?@y${aY$cDzF@IQ^nW!Zr5_ z^S3Txim-M}ri&=1K1)iCJrdL{GN5lWjTM*uVMPDIK8@&$q`YxP^s&M6@0u#-jy2RH z%`l~-x_}5}6|RzaN*+S}X~aP}OeS%3s)3L(nJoYw?>Fh}?MaKX-hKz!YsA)*cQ||d z&^7^H>gaBst7%bv9TJM)3b!c7h><*Od5Cwe=quqC6Ws6r+|Zo6okCUSzoqQiDL5BQ z?2m>9Jrhn33~HGbdDPfG9DZ086lUFYF&dyMmbbk$&CB_M=@RCHzZ)6CcXw*>8Kt8R zH<0%K2#gORF_cx1p0aDNeqhZiw}x9k(leZe@ZoUEb2jgOHl+E-1pfvju3MKrGXTh0 z{$U!gvGGLPzI2O(j$I(vf+ZeLG~lM(vvj?MZlaKo`H7g!_$^2RVz{KQnontfT6G+8 zMq=H$ldBsG=}Hc4@k!e9bnAn%F{is8UVJvh)=v^4E86kiYU~(BvTBqcR}SgM*%1oa zVU(`}-gA+w9MS$A`6RcY$ayiC@GZQKd)fz;gUA!Fql4+vJ%Og6eAQUzNm`RML0NZy zr{Qs|RCJ01Hd*+r8B57ow&vRbGUTYaaDr6s!HksW{@j>TW<$c(kwR+!N}kQ!QJC4A z!NTKJ1jrl`rl93+YDUXd56Sye+&S;Um)cKTdVzs-WnxCokSsevaoeY4)02<|AYKO1 zh~XDteq>c9a&iu!bmH0?B)qgSc6SEO`BxgK(TT1Z44T2~PILjM2F}kv0JPa_=ete= z0xCE7N@t~IN~g!`fTZy^(xFgfHWl#GqIyavtJbOaWtx=IahCyosIvPF(5)0qw=$wZ zQOwRrFJ+9L!vvFr!7|OtsMA;4S{B!Sf*f4iXFaiNzc^hku;pcBY;1`+>>J0>zOj(I{fa%Ww7hMgO26UP$x6Wq6`wN#y}1h5_^&Rp?x`>LylFM!1fb^0%` zYN^1?Rc3`N!VLGQEfLm(>KmC4?Kgz)(BL`-j)`t_6YgcMGWb}+p{DnW zH(dEN;Dp-+8XGR2%|zyIyYaTWarvj<6R|?Ql=#Sgnxsw~j17SLf z+@l*33#ns?nz1XBd?!;_W4s}L$##_Eb=*1AaaXM4$yi&!Vo<|{#&B3IyBY&Y)$ofn-G>$cr6T;c zq>aL?pWwS&8vnhh^XbX^AoTB2gj$R`fAvw2|G@?XINa? zx{2N4@nRb~6UXD%@mNlGMOoU2KYuF0S&vm21L+M zc^`RE1FFXiw$iu{fSuC-T{Jj__Lr3E2$Z_5Vv0wP7oU{8&n)ir@bD2^4hnN{$4zPKxXfW>f)D9H&_%q9pJO4qio^ljdi<7>9|->gaWU)Gim-n8b~fd zVNQU!BWL==Ep|c>^%P+_<$fjaKeG795oY7B!MPDDE%U^4ng-xy8x-p;{`7-1hfqm^ zJ8r0XFmh_}YAa^`cQB|lL}I4~Csh~EcLn7WThYcQ&3VV-6x;Sm?+^?17!@I7FVOVH zm6W<6B(^9x#6km~{5CWCQYzYO2QrQ?Fcz7Xi_M3_V*lY9>uq^2!xQh@tNWw!;IPR1?;jz3}$f;*UjmYya}Tkaf{vBghJt&k%W+mODFU*`5L( zlM6>9YZe8=_bGqmFZtd84qi_tX&;!LqjEVSjE4UX=4WZ$a$-<;KTF!4X)Qw1U%SOz z653{o4bsS#DBOXhL_?z!|CT2AN__f0>#5sri#vmPsKK02HJ!A{77c6{bBXrV z{~`p1S&j5xf}=TPbn9~CS&d)LmGt!s-p$K8w_3n98din3xW%J+UxK=7r zM`Cp*w=11%OK^q_$>8S18uDgyUr$U<<*QSjeJjT43-~@@RKQ=#-P9+LQrtzj}Aj{&t($}(mml9<$_7#G0S~otzGSy z=4wT-b3uXwZ4=rOXh9by>c9Qg*JIni{qWb*tvhnJC+?&E+;xd{{NO!tpJI-!67M1H zcG7TAe1;!=Bdp4GiJN#%=T;^L_~l$jI@g)#RuWgW@z|%wy!y^!r;GoB)41QVGqIHP z6m}XNbjl`L>_+!&Vs08ySYZftwbg^f1DDj5$-R)tZOt#U*3M~X4Z)Su;R}+XTOVe~ z=BM)xRsmL(qVC|9If=|#i504k9I7u}b)Ai7Qz5ax-TUyOzw7PqoWy(ZArMw> zBl1NiA5XA<8Z$|w#a+<##ZTXhp*r_Rh9s4kRGdRjMvljhR3Z*@rbSRl6o^_R^RJ~e zcIVDcX#KF~2|UjL)}Zr3SRpxUySm%C%7>9Hu0EJnI~FGDQ1frh@U4c}7=*nQz?`M$ zhYoTvtcY_cuU5_CQT(?On? zVIEn}OVgyF^b=CARfL=QG%{Wq)+K5$--dxHsJ!z7=_@Mc>s zYi4~DtG{@M`<<}R7{djL>f(uPR4LbBlnAYzYvLIx^_Bt+e$5GNm)=!h(s=g%PQGuNyxgpc&55-k8t zSh-YUj@VhPlIB*Eq_PW?G+9Z_QPMoe^hnb29hhc(I9-LiF+*RRN}m;tC`T9v?zn|= z>Wj5o2q7}#>xqW8kB~ycHo5B!KiVXxL6_kj?4O%TR1?W4TeUDT$+A@^FGx%bx>Aw> z@~5C%oS>+u#OM>3(9xB2u=oKk;{DHQgrjdyq%XZwLohO88yvmEZ4f%|4KIhfai1If zZyyK0@vKa4b2Nlmf-7G7hdyn*BNkgdM%1}7(X2!!K!x7(r`M)gOjcONwTb!sW}({} zzNLFR6Kih$ttHjlGj6RPwJSaq^= zD}Qor7837gtbz%hi2;q7bPNyZdc554GrJzi=Fe})<}Yj(=bvk^9gscZ!gSLV;_%*_ zm}ihJOSIURlX2p?F|kz7N1R;8=x}2-3Q;5o1;WwNVcBQ1aMRNTyfk$^&2{uNmd!nx z-t~}**OQ#he_W5X_SjmVJ)*Uat9%nUAGJ1QA;p$#Zf&B$zH%Y=lqb{quclR?PDy;9 zn}!3-%jC}neJc}bQqceho&CZa0YY~@q&1h#Dyzt$P5HkE91v))XV+(rI2+JmigL2! zV_J31R}MmoP~dFPkp^pP6H7pSdWzLmM`1Oki?f@Az$Oh}ZnO1iS%S+x=o2v#mL-O% zgbL_Wx-P@XUY;9Nxrj->LpC8>=oMVFfnF_3R9NNLIljzjt+K2u6E)V@yKU!Z@`vE5 z*!H)&`AaLRN7#+kt~b{(wLp7&Ey_UN#4x#JOl5! zF;UbAF(Hf0AN@52sTcLW!oTae-ao^Z^g2ut{S}XYzZltbnx7^Lu25Y%B%_Y-%w+8r z$_NwOnOLolUFc5II>l3!2~vo8aIoS#{1!j%+oO$jdOvXF zeYM`J^e(^!#VS%vBf6D(D+PD)sc{Aqn+OI@5*0fL4QOst7e-HpIO3kca`hpPsdO60V%G!V)4n1y%l&o zS7c=M>bh1G+V#TXsp>~`zl~&Zv0q|sDkn>ZQD*Y~_Ge7~%I0shUS)H;ic9H=*0Cl0 zN?^18|AT)qt8fxP*B^1;un-6!X!n1s?kRAqdu#KzBtjp7@_R% zUv}!tn{1a=X1G*iQ7L7#t*;_`wKt}?+2_}!a4GA2il&WA`B$Y}dS@RTyKH4u9N}~? zdrz|j0c!Yjlp0>Xbm{*il!l)m*{`=z{@d-tPto_d{F&Z6RgdlC!jF*b^JmYR9~oEWEg#otNJCR2?ot0l zSN{Q}`k$f$P))G>Wu)1C)~~$#tY5qO68wzIPBNnX#|cJ}uMRqio^l z?33?5WwfrSO!WQdhQ87GnN6GEXS}i*)o+jBKl;7kSKbo*&$mBQ!cTQM{5GS4<*y=g zQ$HsdeEmO->c5vS`^1m(me(KNL{3fJmQhoeIsJ3xgip*(A2B;I&wZ8n5~R0r!?wE# z*28gugQKPd$52EEC%+dQ%3Fei`5jIsXEZ*9gJ$cbaXx_5^HykoCcYqU&>O!>V{D*Bkg~Wx4qgI4VT)VH!A;E_LW~_TFPHP zD*vbVm0x32%3n{5d7dI)*ab&fFku8)m|pqDS!^^yHZ z*?d%iQvad1a246h`p?^5{TFXG_=@D8M-Gw6g7gt96HEBA7o{vFF#_{AaswtOzdV>b zB8rs*jUS15`5;o2>mQ2aZePsEso&&1@!{^K(&%-1ZijTX6w}+bSs)K!6oyVs$8MEK;0^SF&&m>Sld5Fu)Uw0 zz&4Q#j*F~{VEY41c~97stpu9}w3kdHu>FR&J-`wPl*sK`eJ?D+ON1TUn{KkVwel7$ zzno9gx*Z5ZYGs70A5`9`M(InV8cprpsK&L_XoByk@&fZ9%yfLQBIrDfJ|bXq!vYyI z9WzMUYHi+bBD&g^ASf_{^czUQ2I`KWb1i%Vuc_`q?oxAH1CDWsZ%uM;lFja-r@}S( z^NgV7C%i@ZJ(tlSmqzO{zRNGHRHN%L5%P${r%La^x9@ACsyuD)Dm6BxDv#24KYNc* z^&YjK5u+PHEe_iw<0;hcdR@qRxNSdSrTq@}@Z%?rK|RrNdtx#|l~gD|$?R|YpyYm~ zkq6QFsGf@mHpb3YAC8!(k%{nl-NMQ?C2`i6Yh7OJ6kR~FQ+W&H zUgO8icV0`C#yrfx9^eo0Nw;RWcN>>QMSoF! z)^q_T>F38BTg52R747x2g~SU21oX8fYECO0{;{UQai}0xdcDFjuO2|o&}644^Hqx7 zH=CMQQu*4)4G?ns!Xu9<)fmG*_M{9Pk}hIPDx%3hw-ML=*ANXyL5q zL8yjW)@RWfH|uCDWzwi%({1lpCABzmaT3;U)H`Q`QYNGI)!A6iC+Z+x_-)By$j91M z`x%`aZaaCeX*>yxm1dlq#^EdF6Vp#!%^90#8&S;ml0(?BJ+y`|)0f;5blpiFC9k&M zwZ={Epndwy4AE~@XF_a_q1wogW$x3jC(Kg|QzvH&>FPo5^3=8Tn|1F+HZfVlV(P(~ z;;XxN)3o-Hbec^UU(=>%b1kHkHyc#JGBc_|iZ(G8bJUUj3{Az_Zak$hdn3LO5y^x5 zZ0yPO4EBF~Z!ZqsvKNvL<-;CGy7Ohn-FAA`BGs1Zro|-J`YqQroYrHu`8nmVoBxXn z5{95u5E7_f{8acQ3c@0eJio#nE=<&ikC`B|Eb*s-IIOHL&#CvLF4Ue4%^TR&d`se! zuvtcwqDW}ICDs&sB9k0y|6}-l3Enn4l`Z@~yp|qp7$D_T?#0xUP24~FHQ`{M%^l(% zU{K<~4yswFV*tOl5TOHKGBx(70RYn zkU#BWnt87F&kfNtce``Pm{d>oB%Mb#IW5JiRA8>2Q~-5`fGR%yj_B3vSPKW;`i_i9 zxLn^^eCXHGCZkj&n<^U?jFg$~0BnX)DvW5p=DoixzP&1Dc2&DN&`+(?UaIFSX zi;r|4lc(L4%406a8PI!@0#zzU2pWE+C;YqXGNA<9o(DMH6Az^ zGxIQ$g)+-+>uI}fJ^5O?aQHi#KUgWdo00@go_LrJ-8GI?RGq_c-+N83gdZdWX3EDb zlEg|1WIEo)NGU9%Aex+^{eE=tlMX3`e7oQu}NI5$S?K`m(;)z6>m9`RGbc{S;?kZo1E+>8+>j|gz zFq9;*%pk2-{y}YON-*{#FUm1% zTAJTwr3X;W@nQR=w4Xey`7QRe(Ho%dw%$yw)zZtncyZ-dlV!|GvlWNLi(JtOH&dy?KF_8LFTLV zGIX$O(fy1Cl}_e!iJmkd z10?A0yx=n_wj$Sb6E@~uIxsl`+cm6OX}FeOc3pK9Z3i@V97_<)XK7sQyhy)kcG|td z*X?Ek>y2Nbib-{@KMyQ=2ExB+7i(eR$RE5uLifUuOj7wLCD=6>WHNN@UD7K6L zo>=asOdGeBVj(e_V^wS}{({VOl1KiHc<)ht7tI6#s$ck@WQg!=cb|O~s-iyU#$Cp6 z8f*ZoUx`=2vR|;>QEiSTuk|b$W`GMrCU>8?7G*mA06#tk^1^-D@nhKZ+!9k>_Nu13 zd>&xRb2Wy>iM7TsUku#a-LTqHO0P0-<4BGPx?Up-oY=gs#g#2~xM#G45YHy>(LrcJ z%VrDb2AL@YX?p9!rRcKXSN*y$b$L!tU0m~cYQM$t$>g?WwuQ!m70ze+=OqZZSft)t zqzRYu$J03uc|E&($&)bPbBqC}>P9#wXK;-7rugC~m(By6Qke4z=3@EW`r*-xbvA~t z-iVgrWDfl>gU5X3Rfd`3VjebS{cKj+9#dDf2aKvs-BqR*8A2oI)FRLFBw}4HvIM!B zxWeNay|Z=8*Rox)eKQqDlR3D$n}DscY+>p>WMh51n&oR?DKe6(&_=?fJXVXAchlQm z)J?J)c4QFF<~@s14Y#flW{{F=3C*UGj|R)WZ16bll4;#wGtKw{GtKdW%VL)p8LXg) znG{p``bGq{#^kPr-0{8AS#;?_HK=h_^i$0i^PF)^T8yQ}h`lCG02f*l$etCD*Er9R z(p1j4j0m4uOCHUVXbuqk{!;s1qqz=6naReI#kI=vMV5 z5_PwVukDxW#I6`F0-x!55T#%Wz`dHJ(E$>~bB)Du*5 z;=Llyaol-OGc|C5j?doA70&k%&&Do2$fD@2(eA=+4bw?1X>FfUw+yb>`fN;VJV)?O#)+P%3Xk*iEVGn{hn1NHZ+Jde7gyG>;mFw zDh`Bc63$Oor0n3koW9~twF;a|0XdWGUv#%1Rll-@F?SC!J*h)oS5&SJ3p(RP14Ufs zT=CC4>|F7fOI{*x>q?IjItz-#Bl?FsJj%kmjf+g=(rNK<`DM>hbipVNU?zFzqG!Wb z*a0wnM22wc1ws*y$X&f$y)nALGvRs)u>9;2tlAxv#@7p9!q0pK0uN49n9rK#leZNC{2-9aPONLZgM?_@0&x^yzg{RDb(>)pjK zj#}^VPyEIo1^J7`!oTTP4oPKe-rVAC6tFdK?&vk|govaVJOOXz)@bII0A|SOyur+b zKy-vO%O^gIUxcl2h{4%wTe0~CtzcTyY#AH9a?Q1_K0tFr&|^_e*^Z(xaauMOa`=ah z#otU9A;m42om;}P6h zVq1Zm>)U=&dkfv4Eo#&B@8L)LRc!1MRC9;iFj_h^=2nIU67a?EIX9-K2>N!WpSf{ugba&NBHgX z%k|WY=ON}VZgt8G3l9e#SMg17uHY9o*U$e$DD|>20*4ng`rqu>cIwG$N9Elw!2 z)YYaO_u7sBI824BT@RWp=2AH3st@;*r@5e^m9>WT;@uBIOg0J4c2b})#(CN6T`*^sBC8`^cq@0ui?Fb zAX6AWkpddCdGuv2efbiJ%M6Td@^KDrj7~LeXWO)EWG36g=xx*jC47_`+54PHMy4w)kYXR&7_ky0@s%#!>hw z>zk&SY^5Qff86vj^8m3NtqybI-KK_N=7}4L@bOsR(!MoQIGzR5@hJH0_nw2mfXU{8 zXu_CWVLDeX_`@WhTY-8!;^)r=>$mg8ut&BI_$>^59!J_Sx)qQU6=XU3^` z&9hpg87c7>ICDJ!>5m+Ea4pbRQuWnR1&wmr*RS}mN{PPKm%h&QUzHMl9j10``-%rS z>3*2cp;Y~ae@`l0=eB1xbB}q7A8FfWRf31&ksLe_jY>u@m(JnkJw|e1cU%v|Q|*}f z+2~VSK=}mthue=WdNe%tRY`lk62@?~Dq|+uPOnVlSEVL5j#XvIBkTc6^_AO-9tj7r zgaz*0FRLVo*2-nGxD`FiEAl_SQVI_zzy11YdNE2({Ih51Eb`kuH|Q7n&1)ur9G7+W zHMHHr{~QLIUo29b9QNU;6lX~;pUP-MN17YaOfF4X&t9UL9o~xHPf18a%A8-)HB1&* zNNV$=DPS-z-DYh>Yj@5HsxR{7seITOc@&y4{3sFCSfCACs$*#qJ1#DRmL)e_0{SH zio{9KU5O90t~DfPa@$LjNj4(meNc+=YktMA)2*|w7L#~660Fj=nt~sO^RC#(amY9?qd}(OT$4nC}^w zPWFg)PU1jiBg8w6~$KMF9xL(tSx*7~($3SI5Y`vFl zW-mt1!K0w`V{KkmGhAm&pMnt1oH1tKqgd0@yS@=Mnkg(m%6W4Ux)ettt}HD72e?Sd zoEd>?ZDO*NI3e>Xnh-}sl82<2uw|(p$V3ki5BgzVY&ErUGPE7RS|{LTx1>d*5VwpJ zKPlCGtJ}Z|VV0i;J$k5v$&M}v9%+r76Srl}I>#*RN2*+FT?P9O?SxN{`H}4eoO%_Y zs1iiTz7<@41{09%>KyfpXIX|dWYGB7yo_WY-QR3sr~Ta9=l(N{$#Na*b1oP*dz{n* zl@OEu@WbQ@0dn1iPA|&PsP*2X>oN9pi|z?;XMAyvJ_8nFf`w4juenhU(jNLZlv&e@ zT1%W9fCaLePBEmXL!Ui$9wtf;g;gMtTbL!x=i&$+2_ws#gg%np*9(U)!N8rwJakDK>aRsUKRj zMf$!!qU8l@Q>eCnIlB&HJYf82++`7!6t8F%dHA8Bvz8rL4L@GSRUua7t2(}be7k{{ zpewX4InJQE#1RE+gYRlFYQ9bnG(6e=*6O!4ez}H8glsUHoJJ;FT?_Hu5ahJi2R|hY z?<9{c5HG2O_@=htOcd5$x$H=?QncaZ8;j6itTjBa6)4PV6sG_(1D+1vBnX8Nam5Vx zuh3p;2WRpH$H8&55==)pzLF+v8&v=Fqhgi7vYKy#N#j{ORU10$?Y5qykhR}sZlmE5 zH!Q@lrz;`v!4Hu@D>hoxRISzoRD~XZs7Al7U!cHP^`=3uZej>os7hYO((-;o2)YQx zJ%Qr=4t`j(EV*OR6E@8S4%1#!PEH)O;+4km7q!A=K9Gq4P?%Z4x+7D9R#{PItL}N) z{X4Q%4349<7P^7AfEL_07DSv2T>JjU91DKt;S_8`=YMuN^V;8>>Zkt;n8}f*kqb5 zfuX7++B2F{Sgdh(SO>{FNqIrAnXd{nuYkwDFU8Ffv8^ZM@OHE2XyFgx!Qvg2vxFCq zO`&a%Spw6J6!(`hIo^6o>&fU*cISf7`>1pDX#7Qw#3~x|mGCh$FKEG_VxxmrMK-ZI zHBdUAScq4npxrRYQ6Ykx5JPPDB^ePxEE5Z}SiXgq3!kFY7Oa$rXm=0BrQ@I-wB$$i z1Xr938K^ATlf8?c8a%MK@^s;js96eL!EWIOMq1Z_ee z@)1iGvCzj|lb?Wc;X0aVjBXR~AM+Eh$xXm$6?8t2i<0p`(IvRi9O^({yh}O@{+gIkxvg|+cQ&>of59CUxaoH-tFZ-TGF!DH z$Gb6c)zV z(f4GL&%w498K~=MMtz!4D@zDkU#+?NEHX60>&Cp^PUN0w@!elY(pSX1HF)UnX%C5Z z^()Ue0qUR&2FOE&0vJheeYzFIFjmGOBzcv1NbBu3f|`sK)US3#9hp|n+j)-+0xZk* zQVgRo55ej+d@AsTm(u8~V;skct36^Ho>rLJUv885{;!1?h9(1*>ZZ~jW9c1pv{KToTA>dvX=D`K!q&zTy!t%$CdO%eMx~*_ z)PvG@1s9*}&3g2)F+Xtym!Nox5}t%Ijh4~*p39*^l+(V(g4*wjXqxA3cC)DTm^rR` zmn)D|nx4}{1RGVCA1fST&lA~Mg9>FZ+8`^o*Bjrar6}msfxr?8F}}tZU&J)nXk}DI=hlzdDUNuNd!3OEs;zMh0kOd7v`7AQJIfn!%#jGprMNI`ti7zIs;2?!m=1Y(TJLz&i@-$SkU&(?Lm z0;pu`m(wU_RGV;FQsl+n(6;e`J1_7R+adfzaM);Y{7E=(#%Kq zitypltKok`GWgc0Ymwr5DXmGl9`OTVO%PB*oY}TxIIp}^TzQ_&eHF1x~{#%PgUKn@|M-g45#`$g13 zc>^gO1TSMlig94ope#g<#4~xxgjMXwY(O2=*fC1HN((KODWam%uB(;p0d-7)uGv-a zq|+4#!Wu<7#vLL;)eNOBk%h>^$V9xqBmu^DxZQGLI*V_AiS!_5kr+z%%Pgl4PQNjXvBID zoCo2X!Ln!2(292w>4Lbhh-^<<@&i)bGAmF`MP-pA9&CzjfbTvyc(97R&&hE=0^*Sx zaVz|xDSaI(H55fM=(3PXyUM}ENR!-Fn7DiJFq3ptLtz1jXqOLt=vu zsw1~+w3Z6zjgCQy;J;dRpfyhOZX?b!${};`qgs?YwY>2oa1VL>b!;cB>YMWS%wGnV2I` zF3*$Lac5mNd85JDb|C1(UA6cjV3f!An5};qmqqBmEMKD)yb~XaijFrcgU;{rfGcNp zl0)agvY&u^C=aGAtjR~TpNETTh2eg6jGnHJdTJ6bJssc!$`C37On>qy=uGc$d|aUt z+^xr-BL%4>C3mN_F782jbvLOz)$KGG*ocN>DBy*G@NAr2M?^d-V~ANyxK2>p8Mf$&v`UQ|VmeyM$k+Eo<}%zmNojrRhg5*_P#K<+w!9zQcF6CV8l zo4<;*9zSJ|C+YEU9)&v53@f;KLh>r2v#e*+&2DqYqCbko8fWyb3&v8V`dZ*8f%+@$m({^Yh#!j~sr^jy zzF^s@`zyg4H{A{o%_G~_aa$eRL}te;>4Rd>j_qR3g!8eK;fy3r&s_w&TC`J84gO4B z5-DY3FSB=NxSe5;yFji|&q#KA`1Km@|9?qGBOUJA?ly`VO`*w_OgP?6phJIRpR0MU z=2;ByW}ahJjo&_@VhoaNqAnWX3H{TbeiTS0F)N^h=t_bX5xxxL25L~XiPiIk^8gIfgn>jYEgf9w3Qz;L%kw# z0XRwg#CD(8dBO8WCt(z()|NU_4uC-v0fI*6N;xTclG_*Esj?z0Hk@C)3sXKSHZB;|{z9Ow zQXh1SD>CO~)+X>cW|(XvK<%;LB=A&qj8kIO7~xr7W|(N<^xt6>(IQ31qGwT11;6^! z^DtwsSJ82thghsJA5S#q&#c&!j4LDmeI56koR$;+<-JDB2c6R=Uj(I6%OusJ+M!4> zz{Y%&5x1tsq1|%PuO`PQB61!gi;?r}31(A3JebV)#vDW!>3IG!a{VlQcCja8LuSxL zCm_}*hLkNFUWsBpX-C+^n7YlCiYr%4O{Re%0q^?^O47~YQ{3edVT}DSy{Z9B{pq=y z=V%Cn6_INbYN&#& z!c8y%wH?pOU#H(_I*L?mK0=fOe8^2T>wq=&UU|}9t<$OV_`MaH-r?cQbj>CsNKh70 zN;7rpPr#&kj(R3NBN_FH{?$mWyMsOVg*hdlB@q0Jh2RQ?uz)obYm$h?%-Olvv2 z+?<=fqBOjJ7U#d@*n4<|Oyd!jfxid|j4-(#4TL%>PGew1P85G)6M&vzy^IHb2n+7a zC35sD+(MSky_kI3wG5dA|cVkhjjn`T(H zZ(gLwU;za7=j3usWF&94@88HufM2zwD;L2PRP?eSKJjddrGNlUnM8UFmVi`ac;q8E6FMO zz@nE2YrXuqn_vyS6(&Ev!Xqt@>*2&BJ|`38)PjNma|74aLS1yqN5@Kw{?reMsF`OY zBIfTro|Sd3`p>t9vTtsSg#nOn(N3z84JQ@*QnuVtYA)~mXB=U^|0X`C8W)s((|D^j zTN|mzc3gj4uN~L;o$Ixpu;Zc}W;YyP3S-tPtuU*56N8<}p+YZ;Ou+K#6u5zp8u`h7 zSTx|p|N0gsG>$VI&9xmU1mH6hs+HUyi`#lMk)b6U#GCCk{%Wi z5lq1(%K{C2)XH<3S6KmfC-vBt5MHPxAHEjeg6nM2Tij~x%f$7_mj^RmW@4_y9mQnP zJKdPEUM+emT85$Ubv>FY&lY$7AN@XOqWu7k6$2m$-yjHuy3y}DFQ)Tb@$HE3gdHf= zV0A>b*mZySNnTEv_H-i(^aal=(8WFPh94l!ii9mZsbxvQOo08|5iBRz^u{kWx{bGQPHaB#PAe2^5-Rkm?N@Nj$7QESdkB0VPYPJY1?JIEU- ziTo}*eb}Tcl1J zx8Rp&))9^vZ*9Lfe1e^v-1uU{ZU>UPXJoB+KGO$S>5;`=e$%!UVoYtZ$0E9A(Ou!k z2LQeDOM>V=tbZD0O^Nr=g$B#!KO^A)F@<_i;!1HfiAOm^L=uan={nLNN@Dmg8>J7` zxEr6K9b*DGNyWA`wH|(zPJ)PEX|ke3dJI;)MQ4SBTkzsg3wXfv@r(KttDoGIbinuL z04^0{y0GvNRE!T~iQz~k;s)%`Fb&6@JGBXUE70PPwD27fT2%+O(MxK>g>E zAc}~39X8OBsZw%s>^j|vre9-1@2wCWr40RVQ--cz2gO$aqOj&bJbVIz*?xk{c8uFh zFnbVfy|R=9GlD7iBACra8k+WkhN#*4ccb4SNOn-5LFY#_sB@fhWI>{I4@kw$!LqEM zyN)pTc9g&ixVHUH(TE$+$QuoPCY5OxYQO|ngNB2FY*2cn{g(37?IpYh+%_5HK+(NI zwbrYYavK|GHl$UYQX28o3ghHR+-MkrRSixRk=3ergd0%e_t&5gg7zV#Dq5boIyxjNjFKD;{~GG4;vt3hlsf9r<@J zvuI}gwRrbB7rhKune{1b{x}`TYO(O8>S&&c+*~CN zt>kpdusm&?HRd=9!Q(fZ(!y2E1%Ia1&2Af(CN{Y2{Q?ff^mAz(1y=*1>K1Qx>kNCt zTA<4^JI!^Ag=Vf_bZot;EMIT549!@e34A5tCk7ss0o(0Y|d}_+K);B4La(+frVGePW zbB8Cg`LEPkw6RLEXSu+27k9W`pzz`mL~ubw2TP&#%)Ksc5LU z*+K>>$dB?Y^=V>T>HPW4gkzn8oeeK1 z^^o5>rHjmtmyE&zas_V&B(Rss*EZ$n(Xn}TN)nA`3g01S^SoxgulA5=3qxxSO%_i1 zW*2cwjofVHtVV_`%jvaQmX9@7Ou_vWj^LMSUQN1V8=3qBJvJD+Pp{W=H~BO9(*Xfx zi+gU+bK2zr6lR4>PwRPr=XAc=I=@8EYUYz8&D^ApqaP+~vpqIjGZpUHnyGfr)=Z0g zZdR~pm8sP`-KgW2c;JfG`~jL!aOmS`6UM3xI%@GlAymC3VOHb%}F5A@hkS))b+ZWJJ>gOqBYkYHTS-<=1!!!6Ro)+ zftf$G)ZBnIcOuQ57&W(3HTdSl;M9p>rAgUEPuem*CUj#I6S_}d)y0bqtph4CiIQUF z)k2auW+vYV6peLJN5v$?`sb!wKYzls7tA|N!Jg;i3_)^Qo?Dz?nkxW<^lR??C+2(w z8Ea8N;!=0>#R6d{hS(&PU@xO{DguCl*&wwso9mULqrQ0ZT5XS{GovHg^=K7R&Upeq zNWD|6RSwwBd_dEma@Q*NB$`rYWvU_*X9IwbO;;*WCm{&yH1*gi_f?j)Gcno0y-^L+ zs{yrVx)$o^z4$-B(pm>#>;pZF>EgeVNae@}DOwOH%#;X}`Yfj=TL?o)`kDwtR>iq? zpj0u3=Ihf?^oi#>Up!czB{jbv0He1E3jYBF`LP5}Uv6I+44g5;)g=cg*}-?WjsmSXmYi6m=^^mF{^m zF6+c0?q<*Y^n^yOW9Qoh2GFj)?Ng1tsTivy*{_2}aevk(h8 zI(svw_}G7G$zI4P-=`-w!N2z@b;b4eL~bzParze1D@Ld z4Ll$B?Y*rKyavw%ONrm0gkX7<{~p(C_!_oT2M=Q-o+FfMoWzrCoGu<2r*5B?aj~bv zr))SnsRzoSj99hGMBitZe|P=uQeYy(|J{4{ciw;fFYy0aYBc=g)ad&AQA>&6pak4F z{P(zC!!f*-yGAWuBW$Bq-L`z_E0wY zMEhX4nCyOjJG%G|39bXnqj5O7)Pea-Xyoqy4L=Mz5A<-pt&qdk51sN5UsOV{{1u2) z{fz51l+%nGkA3w+Q+QNAZX>(z$G-B5nY}y#zJO zzyj24I`MIUOgA}s-Z*~m$MK% z%J_@vy2``*_6KOg`tuSha?yhlh_z~O(1TvX`+3{DKO&V;{rL}Nqd#JQ>Q6PlO}Wqw znVY#>BGH#hy4#q7&ReVo>)?edYaRUl-W|O4mw$B!Kju5|HmY9N!5T}6-=KtGd8Pjz z*K7DH_MNg0y7AJK9@W1s%0>TbegEqC#ptXBl2E&1MmJj#>(IX_vvug0h#8HH*sC}H z)g3yW`iuenF9CoD84b`lkdVW zln;C0@}1J0TL(@@LNabj2WC6r?0DaS=MjIMEv4rP6UhSIvox6AOC$?AS5TjI;2>JC z4lK5m_zg-3me2R!<9ZGMR;`cffGBZP2fj!ayF6(;}<92=VU3=z}XzN^71 zYOoYdmte@8#vo;2Bqg~i=oFhMwKO=kw^A{<)97k7uE}^}(F@`Iuk8tpsAd!}|D`OB zi~rmnC0$)wM#>&>hyA-7`M&~jXHlOaPSJu5aVJ;20;$Rn-lHrxk;Mg;rb0P^wvnJ5OQIZ2t`bgj z{;?ZX4%$0%qSV_IT=9(Zu<@`>-Zx~QXggO5&Khu`y^V;=!fE#eUB_Bp4x`ww6TMI| znchf>Ew3g^+dbQ5;k3P@k<*dMScvLhRcQAp{%C=;=VL^w?oD--#nE;fszuMMz^bUg z#mo%rZHjrSFRP<3$JrNY>pMTjV+Yr@cZ$Jx3|9r6%l0Ijuc&Y3WFt9)9%z%L(>|S7 za;m-fPydQhs*9%*$=U1_&5xp|zuhZ~=Jlv7Uo6ie!gX+ZHz2DFXZ?LFJxqJF!$q^-kKeXQ9Puj_Oqw7g@QyY2u6<;SD=%GUWZ-ZP)b) zy@KR!`(103vC*H@x-qen)NIv_cH{!T+>JDBxrdayF!43L6Uc0g5P?o0rLf|CnOsQx zou=GyBgcIR4Vv39c)lpGMRBgt08vH?5DAdnVZ2ickkvd(7l0~w4#dyadv0;)r`rAT zqzy6?LSID|%i~GG*^7os6^2h%1gc`DbDUpVrl(>|y3Yv-;EX zJpZiDcPkD2HH)S}P7N)gC$G|TQQ!Q1+1JF4~l(;#Rm&%{RtD=T=aSp2zDEQpw6 zA1$_qpfMK1oq>*(9PLFc^*v3o0cp8YubYm0@K)s?d{&jKLQVJO{dz!s(I7L=PF^@a z{wP1#cfYQ?J>xIQOP}Fa!&%z76 z5j>qpxx~TqA#!J8_gasVVoong2R%a6&SWqu#942mq z^;XiSIjK#ur&P)|D8vzYzEQC&yDrwWDIgQlt}ZlsOFq^b0#4;Y?+v=%kgMmtU7d{5 zSSxWr|2(M!cXLTWEa96}zuZJd7zux^L1EVU1w{LUsmShHbehM2(+I1``bx0aW0oNn zVkv97t@(UZrUg+ZfgDV^(U2M(?C3!6YFZg(7%QIk6HO?T!n_C#+LSe#)mJ0vRL$5y z^p)}1NtNm+U7MB$h06>jMAl?KM7(9XH=yE_RhNUS z@k*@S*7(sr{Kr18=!I_JQ%gOS(wrziOV~{`Nn#Qe5OOBBKGX3eccyvuuwFN#FLfGX z9WzW9PKE1W)F-#nMI)LPwR&gN1w^pyle|Hji@&Z*Gt#m4@5o0q=uEQz6B<;Q00$Vy zwn0!aSqZUt*PIuevz`MRLs=hLrQL$(cT=OT$ME4*%*%5N2*CDo4$dqSC@yP}!&SHd z;-Ts#cqmW~x*fN@twFif$a#baNvf6ef&+OuB%YLsTOBVod7t9-Ta!1bNp){9AC-?< zOvm2Ha>%7P*r{P$K_2LOh{cw1z_-ScH)bnNSBSzn7baGxy4oKL$HA%A(PTyVlz1Ei zCgYT-#C(=$)LB@rbA~JiRs}UnhRB!VCd}MRgxSSm<53+b6lYUc#h^7~8iF76W_q5g zY6!00^igh`exPCL?QT1g+d;t4bjNc93B_N5BE$iCpDaS%s-LeNTd5mEy=u$7$Q^+Y z8~j{fIpdTm{C%|ngCr>1>%hWB?URR(zg5z1dywCYNgSn&hob_UZ$57uUSdELZ*}gqJ!%=D*!N2?r zD9oJ35k2m?uG!zX%5A_sACWn6PQ)0L`-Nwc%a*6GPWcNnK}yt{`0FxtMjgt=9#1D<<~Ey;kr6yg zd_&+pf<>0~>?c3Q{tO$_O2%uef7QaprF=3Gq>C?JXOVx}67!_?P9wjrwUzCn)=`VE zi}GD2+o)T0B3p~tbQ85`om7hc^mRzBO6GeDX}oy3&!JTPh0ltbLw`pc-ND`(6&6oh%CE2!bPdV&Q|<$Q>W}DYE8oQP zlusffI9A!9vsKyiW8Szf1`&OC%mjYZ)F-G=g+)La#TCX~PiY&U7Ct-h*YP9-0C8GF z$zL#qb%zAml+9w73rJI$B_yf-T9u*fB$qdf(=IL4C>6v`widV-+*l5+Qn z969%*c;Cx8hjTA`~5v@PnznvpZC6n%KYUS1l|HvsE!C4-@kTJ&I+zIo6T)$|CobB_?hv)>s|Ackk)YY#9WfO5%2hrMsE zGj+xMV2Ma`93}KU1iA7M4uqn(K<10IRM~ne<<7m4nZp_=WpD7dY_tuYvWQeckKOzx z@^nkzcq95!jk1#9rgf3|3a@d)rq^^DvlYE)H)H?@T^67w!%s?7^{gq?Q>9WASYoA1 z*4@`xGi39pJwq$OmPa;l$9A!ZKHmFa)9SL zD1st7rAv4(HKJ=r8+e@6j5=+RqojS!aQ2nf{MgHdhuHahr% z^_%-6(fy{Vm1+Pe?D(lH&oNW)kMXo{;wMf}OK9j{ai;l~g*y0Ikj!`pT;FTB79b?r znEN-&iClX^Xp+$&gx@1{A)A{7I;B`keo5PX77AS$%wA+ok9K8%7iDs1^hC%$#m?4< zsG~zFRWh9`=|E|+SeVpO57Mo~a}idOrW z-W%(#D4s_i zW7Kf*7rY3-Vq80NsfAZy)w#cQ6)j6HDkiyga`|{{ybuSDb-ubtCk3xKt1;N*=g0f0 zEz8b9KQ21Ce!DSRzwz_64XMJdFEBZ8Y&}Diph2AY#kDcqjSuC#On;_z3sIxJjlm#oaPa{){#@N%$iJy$x zxO*Jiz+Yy-jA8G&$~?#m6R&~;eV65t$D<+?cwVn#?haN{bh>K z@({R0&H^{fxdVs^zdWf`V(o%z&-~4a`DGnYF`Y@?43M)@f^|if^eRIM=HuNVbD70nfCd!f( zRVj;`c}L&?{WFKWD*&!#>&;;1+KE;4fbc@1U!Ajsa@jZ^DAXFe*#oA?#ovHEwd#vn zDIP7DU>A7H(^NU^-S%0Y2qE9S6N;sTRGuHa5?*$~uVsh-f{mHhap5iFnLy6-?h`P$ zC_7J7daESw)9lX1KpyXhR}g!;EA8FaL%~_h`5yK$hUPF7jWN=^_g@-T>}d@D4kI*i zBU8bgoh@`lT&hxJNVSWT)t80y9~zNosXleQEh{IIC??yA7~vG1oVNEyc5z57B;1ft zy61(6Fah2}Sy_2i^cg!ZVf|juP3I=dgv*l6KG0Q>ROD4SUFL6?PX{XqJ9;oIk_aSWtJtec<+T0xIyRVu{^ zATF>TzAgOh0}f1eX+o7xqW`MpYn9`zPHL$J#DD?tuqe*YSt&fF|Du^*tDl^sSh-T` zCQWIuehe-)0?LL$^X0M9iZGNN(fjR(nK%}&qb9d*M@_0B|K8fCz(9i3Z+_5Q`#K}5 zxpp^Od%F|#rm+gJIj3tvp@myGG3|wMlWyT0Ao@9CCNu!FYblAw@R*RE4 zpICP&s4jR|UMIXw+g{;fjvqr*a2oszW&FyhM2+G$AbE0^F!pK11wE}TiSy593fDsB zm-qW-h@|0-mWyzRk(4#YM6a26(?jhqai+|pw^X;k4@#Y|7=nr&&c)vJQ-$_>i?yuu zj`DX4!Bn)e0gIJUYC*I#4{Em~&EUeC<#pX9)B!?GCcKI`-5OGgR_@M)b0+C#-Do{z zAN3NS0ty@#_!V+7TrMpbFwN+{iw@>eZ@2HJ{2V`AHgVi+dhT_78Hr`H2Vu0tFpaG^ zM=Ra}ac7&zsCW{9vT}`OM{EY@2OEla(*eE7Xp+0+a6@=)?6OFLmPksHl*!@_hS+8a z8bi+GaeJ<_tvzsZKV!T-6XpJbn=cQOd(svhb5cP-z4OmkuQ8RMX8;h+5%L{B@%$nU zM>?Jkdc%6;^P!v@1c~S8Z4l0GpOhxWPbT(GLuz~bZ;CpxmscXZTfKwyidzo(;QsuP zlXz9tJE#;X92Kb-I_gIVGH>AY);+_&6fR~J{}qAf=g)0m1LIVrZGvr3iOK(SwbX$Y zWhAIC7`SC(`&k=L_Ah;H`kM6B>3LUQMaH{q>$p^(*F6HtBw7!OJxKCA`zq3;Pq^ue!7h;a3V)ks z^lW<#5<+cN%2`)tbPVlG5dl@4#>X74TAqP)Ahni$GTU*p8H2te@~n=u4+Oh#&vfeC zn-#KSTCsv)6uJIlZ)IY54-zdPDe*at%_HIozR|stF5^b?MlRALW0d+yd{}fkoxkJb zRErzuj`N{@_1e2_5~^Cg`)*vH-?EbTeSQ?S?&4BX&* zHP7i|CrVM@kLqJndK;PGmu(rjp#i4S#}io&D4o%x%ZK#Q>tIh_wqWb+c0O7z=; z+YVmjVz)jX(g!NJd62({!P)60d?^7<52MGC3b74-*u?oYy)!WV1_Hx$}~+ zOpa)gav~#~>2EWCcw}0(($Fr@#tD+mQ0Sy9c?kLam-uu1(@?t|!Wk6R8}4qO3+^1f z41*4@dmo>|oTHa)!q6r&+z|O|E`+?cZwptBY@P?9xezCLnsbq$9%Zr!m-WJ$m3y-+ zH7l|Pc?fodH;fmFs0?Vd!IwDymcFq4jLOs6)qeM}V# zDP_Gv4ESgkQjE#BgMa}LQbK|e(kX~oAqU9x#n}ihU;>UT*fRd zIbv{K_PS=9Am)GzP+GZDU8l#NSGOf;TK=-z^Tj{)BgHaabK_mCM)Wv+1UwjPe16Fo zq{SHIM#msOgbGA|;)@^L3JD+-V1jM>*b2?_MGtC@As@sEV|kzw)Boi%;WJSt5i!$P z;B`t5i12k9k&M#jo!+EMJ%>fS7DP@nF7(oZOkaENNwIOU>_(D2n#ds8sXU~T7Kv}E z%Muqa@kdWv4lwFl`GXxyd>}fCXO#L2sj#H9nZ97oZM53LnLA}MgUVi;q?Ppam!(FY zwq|TMT+1FR9i#z~(*mS9Qma`q>Y@=gP5GS9@Nn^$5YZ@J|0}`MeS$Nwdb@l0>}lwN zufGkB8^Vh)UPmT*w|#|QxmLE*6mqQ_8iHMo!Asd-zYx6(b6?+&=>wXnd2+_?%fj52 zk;c}IHVtsHXzv7b^NvcROz*x4upCL5{a$pGG4Xpe+~dUSpY_g}@&Sh8oU$5fd_+|b zYGfW}C|gWci4iw&s~P(RQI+=2K7+T;t@uD=>~;OB;^W*YHI1=?pL(bLmkq%{8o7n} zJt7l4_O>4zY#@-h>kcy^$!ax*VlNsg&Na)%V4(?Xj9 zNi97;tFGaOaTTQXTYKvXky1oPaAe7BfkDekRMjD(qqb4Hsvr4ly81kH^){7@ zuFPU^bd{x%&JoYMjlUNK~?rN1Ke_Glpf$&*c5s=EM64_)QKKu##!lQ zAz{2NB%FygolZU7{@>FCw1M-kuWU zqvAA79t}Aog=Hqa*Mbn3q&=9;7!@GpSAD)YU}bDK$kJ;M>M| zg6CYBo9I2v#BV@dhkP&bK5k1c)C^PUs~7@>TTb)3)<;kOme$`EZM=He_f|}P&+SbA zeXnIdoZE6#Z~Yl^sdZU((>Hs!$8;$pi#I@FVs1y5c|zE- zxZoMx9Ofx_Ua(bdy{IOh=cD;$+F9_b8rw_n{#L*6m`s|^-zQkUc;PmABNFEw;`@f2 z_l<-47@~jsyv_wt52ilDL(2YfY#E)Piyz_#S%Yi(fcJy@kUX-%y&twCm%Z+9^2u9w zxE7`Z9?6yIfEwWbLfuDjZk6M3KzRHVIQZyybsK2+=-E+&)b}QRYIu!{^JgoW;QiQ=!VU*=z+Du*OHihhl%c5e;e?)($<{v+)*K-KF=!jZ2a z>*wY=-4yv2abRN))0VNH(ahr-t@7`x2!t?DY&&J#2X48keF;^3X-vHq)1rF)(Rx1( zVV#`6S&bjoLwfeCJ|1&*@3gv28kL_OJ%4G;bDclo>>1bJXGF&iz`-As0DMAyIN2EG zZRQ-jlW9FoAp@;vrv}=VD|>eEhG>Og=dEPRUX$s5s3CvFQ9@3&%H84TKgYGD$Lwtg z(nr~sKlA%BTv69>xMf?iS_^Yw#m5;IVbJ~N43RglJnbrnkI4U<~S|>mk7mZ}Y zGFZ)KY?Cg*hKOcmr_Ap~twgdM(mX#KJZb=UzM5%lt(KDs56UD?&ykz3TDiB@QW)>` zklZNixlZTF`tx%3$S#}9-iiRre8-xZL>f-Y;4RMl z%YPj|ZJk_waWXq&Clh0Bo8_u7+uTX!Y=6VyRg;XC7ncKvckOvXxD7j65 z#W|tCNURr+(UX^i%T9}DTQ@h5dtDp!a$)YVctdT05T6N|u&sQgA=rQqFc*6}O%Ttv z;%CFMk7SrBss)(S@k2xEja$F$b>-o9!lMs{_;|kFvDw$FxrYWNV<(Xo5Ez*Td zNGCs`Z%#~W#~2-Go2m|S9y|GJanDt}1C7g@o!iWam=eDj=UiW$6OBkp)gIENiu1vU z{I+vgQAynzlRYYrX%(>H6fFhOv<;3F{^7flW%J3^LQLJdWCwU4ZX>WChLp7sfWL7> zZ{5K|h(JsFnK83-o?`%EokFE!$XX50F{V(eaAT1%SezPl-vH zk-voa_7xGtRH|r&n!f=1;7DQbQh^Oo{UlceKz9{wP&0vC-6WLfwmL*= z+-Q{5ArD}f>uZmAb1xFM*ZYSauVF(vI87usMN|Y()fUzpCxbr#R1|MU&ShHrSjtEp z^j2@DVv@fHN8qS96Qa!8T7{R)+e}pGBjm2?;;1W%A8*937d4IOXNxfYYdI7y3(MrC zK+;$4hMbO%fU~27V)(&xIODdxrqBbXq?s_cePjm9C61nG0kbYqagN2r5Z1{8q9&&D zgwDs6Rl$0a<_T}N?*Kb-KX?icF!{{VsYkqStz{Hf^8r*FV1803ZJkK;30mLg3A ziJPP^6pi63+pr9!p0KD!-bUFlVNCVi`fOB!w>K<*R?V@F7&U+~JpE}x_{PXDfo_X} z2J%nW=(k;hAhnmiHX9rnbzyR>)c0S#L&`IllgzY!S`w~Afh@-BK{puOnI|7CE@(oK zv1}7n{4FJz%Q29MQqcz7tY;Y}$LfHNN>ZrEk)8R^7$=EfTp1Q8dq6Tovy{c}DZH0o zQ3lhHY*e=&Olm;#E8+nQaIEEKD8S7@Zl+1HK~sa=VaYPd7ypk-^#Vo}SD8LD{FGG$Mjf}bH{$`K(6t7wdNSdIF6;_<-p_BHl`x?DytiKOQBF-5 zUNa$anD!8I)SGHVom`}1v!W+8dQxFOSnrPNP-g^#bcUW+N6$N==fZ~YOsL2*_7GEN z9i2<)Zs)74IF7JLU87%!xA;}*tFI;{RX^|Y)x%egcwM5K+7#VHQ?6MH~q?9rj~cvc53Hlx_`&ObiqY`8WS_(8GOlOea%p=u zODMEYbAp!Bn&Wg>6|T4DD1E-n5uoHkR}}Q zHiF~|(_UgtC$(?1@6o6$w9O!46;rT!;cIAwQ<2!MwDp<%%%lJ*&~n5@2(}9H*CW9M z+)86>1n@(W(YZH9(y0U9$_`UPJBhSJK$qc+h(!1fGy?}toE5N^RMY=QT4p$2iKTX| zz*7#@)^n%6>rJogLH2}3br(Nw%F5}-h>jpaQT-Z005h@cYPHgvhZFTW2+~_`;v+Gs2A)M z38&Z+uF|K}QNW3Cr{jr%vcg0v(8vHUfRcAcDVmWq!3%}2S7rPba1wsVREJ{0VPe!q z8r(>T>Etd7Rg)T!A}i&;VK418)+C2t18Rx|_JbCO@dPC)Ht!scW8mP}R|t{D$8UB3EQ-K*6M^w@?}rx< z1Lk!rUautL#8TPL1N`krcnq~aj_{B@EhfseGNYWCv>_L2#4oPhZ;`hMXJ2B!k4Bh`mBiwP7SXfA9$YwDzH;pqWEPBl&te=YW9T7EV zR3>Nj44F;;mrU7Gxq35#P!B3byV)BkRCeVZ%#7Xy2VG9#2W(W>VBsa!>L2x z0yp8}KFwj4awtzOC@RcC#C(J>w#__FcWz=k#O8Qm;W*8~?=}F_saM;#`{JLHOwuUS zj}bQv?9%+W{JCL8)%k8SksmIMrM3mED7rel%MSssD9TU0HSbBb;tfE-v7U_^4`V_S#X_%&b%=iR76c38pjeja=y##yNw*Z z)g;zr0&-6AJX6iUFRa#O!oS0%MDpF>DY1uwyyhjFB{q==O@(SZi_>ai$~b3 z%Z81-HLNKO;zdH1b>8zCONkQfDGia#nJ+%Wh*6g$KQU|0{FHj=R-*IbSNU-G%!MtS z6}W^-na>a96nLYJn8=kTk#)1C!I{FUmu2DbGo8o(c0kfpWXzNv_<$fo8g3z0&`I#u zzA^@uZF`jdQxyV{^o~Z#7XjwjGsPY2=rUTA_f zhwy2J1|Bl4mdTTv4Q(uNbOxQD2gT0h%C`18D;vXeQVz-05Nu4>5??mZ5bW^-r0|@L z>CU~!)8Q9RY&(G0>I0qc#M0j9dfkyq`0Nm;>i#L#x)9Qojg{gy8;J2({rBqoNm+e; z{|GhRoI#g8iB|(d7{`ScbDf`m9DV?WZq?*s2P3BizOL)~Q#%#M#45cvnZN5~`4Q^5 zr|py3ujN}1;UuGp*Vp{q0aFF=Nd=FFA4XM0Reo7Qc)lZ7yg>s z|98>}_nO?2v4@v&8p_rYBU3faM<8QJ7!d?}u7zl3@;Z|kb6_?~tG+}-5}m}PltbD_ zIJ>#(s`Rz&$zg|x3dc5FDP3*$RPajS$J=eD=<}!(cUM^0IWBbK2%^f7Aq(-a4Xa5|dVbn%lT5>Pk=-SlOE z_M!SyC>~Fy{H^{81O>Yb^B1mJWXmP-OdlXQ9QE+tB|+N>tTlyMEO5cJ`f*X8|G-h6 z66t%fJXQ@dP1MaSMi}-*143vm2nL)}>xh6s@Cn!@#R4sa0B#<9hoXk7mE7N)| z*}ZQgS2v8p8D$$!S&pbTf7q_{HQC@zi|We+k6wjK>;YQJw7$~pL-XJliuxrLyP3Q6rZT&`ErUbM!0#| zjS{I%=Cn))k7AAPPXDP$X@XeT(l3EmBfq~c%t{l8nIqdR0vg!an?jWsvM3RhmfaCD zhqK_Z^R3gpE)NJh-->(P&$_lJzeHv+WY{%v3OnY@w(bzXxt${l9UleyD>Ma6>CR)s zc?9~wx$s`sWrCoUGZAOv?wj_m&bLl${|O^5H^z$iE#uq%m!x7MpCCf>pG|2ncNSw9 zbtJ?oioCO7UzIBGzJ)H|)Iqw7s#pvb@>gL^srD7$IB=K-<)>&t0#Ukcdn4k@Ulc58V0J2JC z!DHC#HE*R7wQvNWba-9F+%+ukP`ZPECU0q5c20$f;d#*;axBA>YB5>8SPoj7`kU+7zY;Fn zgqmc(77b@*RUrj3$h#ph=LGi{e_C(|OV|v?mkal?ky+9^8#~aLI@bQ8gN4_tm^al? zoBo+f(7{>E3-hyrf!YxyQ4?F3)m&Isk6x|k%Dc?nq1_sOmIO&U-~7irb%h;t8dQQ&?4CUGzoWn?iKiz2|8O{{u1 z+pAJ8CqE3=-4kr_E@v;r1aH*=a=Q@uMc@Qm&nDgih%!ijdJ;XE)9lgO@ z(UZosPpA6ZZWPMJq!K%7hCncI;|xhG_*h?ACq1M4ljiiYaFsfED-k_W(Y1eFU_1pT zGZugK<^-(El`m40kFnqsQf*JF&-Zd0g12ioaMsDqUrY5ZyWub4@yVppI?#JSxS9H` zFAFC%C0onS~&R;`?|1SU-V@WyoNNIC1XDu41!+g z1n?0>a2d*12?y>rPDLEe=N9v%uH<^U%X`gUZI|sc=NZ@$wcYKqYeh1&Ny2mqPwZl` zF7S*FjF@Gg$E0Hb$ugT{K)zRO$1uOatqoqM*7 zFQ12MmRUx911#O0tx`ok`@@1a7&=+*`sa+OE^`g&aSiFDOZQ~y>mCM$?5M72@y|H} z^}9+91%(p*8pbO_UTQ!{>r1VUUk{CrY-3$NCGN7z;CZbaj+#lCB zL7xox9KM;A+@W7637=(vl|SH}Z0lo4k-dz{)JGT&VQhq=k}|V|IrfD!WRtE>Rt>)^ znzv&PzzLs`y^u3|0jsVhw|ylSmOZM_mf$#VY$VlA1kknv2thWvyi~?^sN4hxohQ3RktLI4 zOjIE6<`X=pNpAC_1PDY-zq5T$@HTNP>DbQH+if4G$Kn9>5)0)KU8|>HKyg0_{}Da~ zyFxZC=Hw#699UxNGB+Wm>-DDWU>o6v;BoMJH+aQyrLkr%IA4!vMf|8ziEQf$$WMBC z45Mq}kn!_1-9#H4h&$@2aXS&2E8+bmA2mnBFkVaq{nIfrG|>o?eNYM3Lu2sg$fl^5 zz3JDE2>)2E%Gq@Yg31U`TAxL_W%eF2j8GrOXStach2Ov89;1cZH0Pul^&bLlrBo%+ zGcw}5`(9T<;ux`?oD^=pzAPTGXd<6Wz1V&m<~wYlmNH^=6Bl8#&AcRM{QS(d4XM|b zf6~X(70&rbPzC;S$@q~0KUQE2x^eyhsFQD*ux%F7tgo=FMH|g2Hu?l#zhJ6ws6B=R z%6&mTW-NYs$z=Hs0>0R?&JRU;MN~s&Rcz&Zs_=L*>MQT#ERep@7$V|%gVPXq5 zsu7!<&+#w%<)XJ@BOp{vq;4)uhn4To<4%aM;HOS_D@VjGz>8%gbhZ-zg0(0YRyCVi zg+qC3bliEcl`V5GWoi#*VuOw0G@wP0aGi~93Pu>lbnULo!D+iFwxyny_j$vT6f>$&mjWBGuZrs$L6O%j4;!soz7}O9V1; zS}q-!4T=vgx`Z!k$DgkW@*-4=3Rd&T(c(OYXFqK%hR`4OQ^c7vJto)w1GHk*7Xn@%+f{*@&gVdn>ZIi*>7e2+c_x>p1F$C7 zwqR7q^y^H!4AN|PH8sOBEL*Nic7UEzS7e>4F?ASiR{RauC+&6Nq+4ge0D)VzF!n=w zv_vbC(Y%KnJ^cC4@d&qxEJS`1&7`ex*FgJJAQ8%FeSMslzmh7&&koJ^8y*B>W)#~F zRijWwP+Mn|{D(+@aG9`GEIhC+n#N@1hki5L*FfVUQ@AKg!YzyX(l7~EM$V(-q~UpM zi}UN^h;fK3{@#2i9j+1>LGu7+L{R*EtZ?~U%0b{L`?U@zHcBYxru4>6Z{=RD=`l_| zFwnLQ;kpaML3WTbhOx z71dEEbC{afnPty0!cB57Rf)7rm9eitr_eAf-ag|A)l>GIbnH?_r58}NDajvXj1n$( z6a9mygiVt_Wj;Fnk(;Wi9{0oazMIeCwp)Xv9@{21eWUmH8(_Y!Un9n8?^XJ!(FYey z2D)aT(dY-q#~lEo`CQJ&h*;fcGJn)O{N6Ppd{(nekihuHsT&Gs?-NEf$8*bCskpc5 zK^hpNNn|qq3%C66MqIQw4tNzXNzC!1qyb*Ly6<+^?8CQ}-Pz8chSMt!Z zbh#cdSNvH0N#x_eC~fMqoG35*QxpHHR}<~nQI`hNx)R=aBK;umP~T=8EOQ&KW}Y3q zp(Oz+o0I(c+5ED9KI%h6;XK8|yyT}|_PX|K={y(`f008iO6iNosrrsWC;1KFXgyI{z_O&7SN@$qOU!RyMh>I6*M- z@6!429K~Mkeu}->fA!`HR;deguZg(R)k;+-U8a3W32!3@cIo{1!!E=qw#7C=e=8dAQiqji%LCW=m&gx;?jY>F^jcJnx}C9j+3(n zVDut)>YcrxmUr>*wKu)%S9}WVv*-nB9h8~yBt43R$IA|%W}hqxJFgz$rCNGw#wxcY zC;i$*{e;2|;%(K6_pYZVc0(n!Z@NYC*Q`c(E!sKT+>fgmNj>S(k!<`(Tji7z(OiYlq&&By!d&WKC~s+wvDF$9AFV&wHJpRl|_Ds4QZ=OzX1* z$P6;DO@8<-&G@CU;a|0`>9NUZ7EomW;)Y!&SyCh9lOCmf)8%riV{VF14SCS@5HErc zMHrDGGpyJpclXn0N^;l;S#g(v3b@%D%^-8kabLYPDfkkCGpu+Z6IQOxf9q)emZQOU zj|Mj#RV0+SCY^fL3!k+G9xMb(nWEPyVN#QF5}z!P8_x$rjlrJbsuKQ~r)gQ;D)=cC zgqNO3VNH8oe@~O*Ps!Bf<5(4VQqX1ybd-G<;z_rWVK0HI)(A39O0juDd0q&D<`?~h zJqq>xk=-R)tS?DIaptT{hz6h@Grg)bRl)Q+A8LYC%Z7lyC&aLuTo(#Y(ZlnR zO5OY0h;B~Zn_Lebz3_XIPfo81f`#YjWZP1!W?!iqZ{?RLknN*Iiet&_k6A6i*1f;| z-{l{V7hfPDnd}s)-X2N`>I%l*g(o5*wKJxIAXCJ{an;hgjV3#|a&lYc%UDivlMj;& zh}7$Py^BfoXghNI)2W>+28(ByP0z~n-S#%KROn3y%Y{>pQJb-BHL!~&FAFR8$vwj? zj@8qd?`Nr5kuCAU@zXSu<7#y37MA}HFqxU)^ofhA<5bs7@N8ilh12z9>eVc{m* z%64+@-_8Bttzwczc<2rJ02M=?XA7(`~3mJIUh)F{`XqITwjeNvu6i=1azKVLnBz^lUgA~KyB{c=XXTtptT3|<0AifhQs)DL8O4lxMmGbLsg0YCYRdcR zBHfJ>P&cZdNY+J>5#VNln3h)3QY2MaNce$J9$t8>edSmqhN>iR3X>rsun-co|bZ!-Qg-2`Ow1({4Oy->w>aXXXWQT&a`FU2g~&ws$r6B=gWpNo?VFAgiG z`1wz`KtkKUCMslSlr*&FcRo8v8@l(eNciELj)vH-hSV`{<)C{|rUw%n*mh}mH*mK> zuA2YQMShZ>8t_*BM%Ne+cgQHvgk4%{(dWX-8W!anV%tf7gjE%5h`so^Fj>{uy4#Np zHMZ`}tVO$T8EF!hms}G1L+)}ZmxH==!ku3O?$;gEjs_?+aqBl)&RN5armL^wYAsi% zeifPtJjAcCkiYntg?+Pc`X(?Ku<DuP@R<#sBxTq4UllI$@3y^U%*R0g1gwTR zgfk+xz^p91Sq#iQ6mzR8AY;|-W#;0@gx9e;emw#yc!M%Js)&7(jlt$@z(&V)$qsIy zPRThEE&DLs^(>nYzwhMyshyqY*cCk#%>p!@^|mW4aFpEvCkhLWnr*rp&)3H9q16)? zzIu^3m3>+`Yuq+3@r;_*>qtF0{N01XLKL}N_4naPdw>$CY5^NgJ{^fo$dE#W#2moS zcb^>*PN~e1UECyq=sxZ$M2Q`*d7%WODiiu_#0_57!9V=2D?Ip)L5N3;Ui9-epl%>P zLmXw;{Y^ea0yX(W_<0FMq0w7;zZ&5-dT@6pUqR?#sV8$b^GHg;T1GOedD)4m!Co6* zpwE6*DBx6qmkXbEtux8FU{e&&^U;UXX5AH-1d)svr8=?7Uf}4Gmq&43@WHI;P}8p5 z1m@Quw-nqahoGYHBY>CZqdsWpzrfJr>`02i9%7S%W*o3Yb;Ar4&-J)Qg_R5i8iThR zI4*@Ap#GdXKzQNvMBY{q{mjHzeg|f2jlq+K+bq|5GflWF7KpPBWLr%jWR*mHGP!UA zkXkGE2$GU>qX~Fv_sg$MSt1aC zT@wc0lXS+?BxpB%{?#(ZwPy^%5$TWa9V_8^VlAyRp;E=#z!BnLAT#IT5iJ~>bcQ93 z3>mJawyX@Kh+wStCN}(7O!9-4LA-DaJ~j~|R$-Tgm6F{P3Y7uCF28zu`~Y3itJGuM z!A=qwgsSXp^-Xn!uWmEvHxQHKcJ6n94dUG9)#9dN)sa=wc_gJ(^jTu=%+H8=wND18 z&qA$5LfgH!ENTCSs8s^Wg#r#|9sO`B2IS`GSdu`P2Bh-@QaJf<^%dzQ?H1fpc>!IIqt3DUN&5|3)AcvqLXT(r4yvhQZ1%hXi*oXG$hz~gF?AQ8RcTf zEWC9x!v&hqE*P!&5OS%-$))YA8@m=YDO4+9)Ky(#+3R3mXN2abB;j4hvw+<}=^XZY zQ!c!)@M$sW93sjOW`e_-CtyRB^)W5Q64!)OgG)#hhW$G0FaBJa(HMW0?3DwPUg0o| zIdHHO%Ft?6;meOlM1ZIvF92X8`LtWJeWT>^LbcPB&R?zh`l=UYQskYO`OXCNO7jV~ zL@a5@yp})?qneNFkDbcuS1g7vl(< zwf|#y(Rfj!*o*aQS(#=ig>Jo^HW}tBbvYv+?IJmCBoN+>=9&?{kOEl|_6~Oj;`W zHdIp*Ovb5IGVr*HlCNrm*niJ3zn8#JEA_%)KLDYzZ=m(UFaN9uEbv4HV8Y3bdXPEn zs+J6+8{>+fvQBsKF255K``I}pkU=2`E!h?mC-JU@A}zpI8g;%fhenFc=F4(~F@tPu zr29Br`~ZH0l5#2$u^y7k0Cv`syQB7+)gCt&73*=Th?`^`RHHagd9Qeho?gqy>`q_P z7;I61IhLZCq3SoOV%QjixS#q{0=qLztUI`CDHz1PlKpCBp={Eo!1?LC{C<;Y=n7Np z`RRBVUt?RrWg`SQtml1&CAK3$L~$MbPMz+pRE|Ua9!Hg(pNXw_xA5P@Te;18JdelO z)?;QeGA|M%Q*d1R5BeklL=Mo_>e9;+NbELgYb&qGdVcE#GZ2^I_zp4Q5T?$sJF+ta z;F8RZ0jGqKx<=D}hDa-$`msp$+{2I3eA&W^t=vqE3upIEER_8T_pLv zh)pQqylc8mi@uOf?e|vyGEUuL#c5jii;;fhwZ_ojI+`CCp$4Bno>P*F@LNp0l(<9r zD--^9RwNV?G|8?K6{Of>?{-9$m0hODc5l^P+=8bb*N9eyx3Gt{KbPvsv2>aC z?%LRx+Lrd#ZD@#ZCyS#jP;xTfb}JW`hI6*2gKd|S-)P1|WO>b!gk_DEX3EZFm1d@g z#+i90D~+BG$I7K1YJV}<*7;EE%?+_OoX287_V&jJ`guG{S|l8&9=IGKRfdMt|sL^&`gygBoJdHRxjut?vEas-KnX zP5H%upep}qrZ!ObK`1+}?aZ)`U&|`>J6z4e1v7)=0n*!s3G(Mgogd@Offvg%vDf)E zAKKQMObs2{T3Yug#WxYnmSaPfkHRL+)IR}-*Cj?%(>1vOGqYwRtBX(y0dzV%t%W(= z*r5E^+g}90St)iJw4IY_#kbAjaE307-xwU3@x&Nu7LBkX2t<9^@bdVd#D_qf z&`A{AsU1>GjtrkGeacY48|KF$h;sFpSresXJ?+g?7|Fm*&vrf0b~?gK!cRnnP;mwi z_w?Hjzj-ct2RgLtq{bW<`H5=JICgOl| zjn{RMcYm)6q(uxnU@AdC9TqXJj*m|HcuZC(NshFnRGntch+Zs|LhazK;nP9C4NvWm z3tz?xdtDnB!waA1j2lFjEFHv_3fWFZC)wOiM#(X>N%^>I;94^9XvCT%2`oIu$*jUt zKZjfq7A8P2_~UXYxIxE|S6^KSi2$oUNd_B572)=8T4T`!%y zG}A{!7z-?HX$C~}^=D5ImN=VJ)x7(hHV5Y!!W9rtA6F45Wxo95Y-MIwZZ5ov$q4R1 z4(ov8KIX~qA;G~Zq%6_}uhg=82R+N`gHG+_+s-Eqo=vBAcq^ySCy0?%f(0ko@w$u+ z0h}ID_AyJb(|}U(?sGfM(zOp|W2~eMn6(Nh8z_b)r^yTmtK%5ceqAJ7`#M(9Ye9L5oxx`L04t2c@)w$Nw2;PjlO^64^^0}ebj?EyWk&v9r$@hE=y3|^%AOQiwN zw@47@?Lv*dBl&@_&|d|H#Uym$bVGe@2li(IxXoOiBNpjZM9UuGL$2CfD0fh8q7q zmJ#EVY5m+$QuCdwO`@EHAbN3KFzAW$I8c`9EXJAXx3gYOm`|t3FH_67)065kf;Jm_ zjvdYOz14@JZjKUk`aeXkqhwwD1sap8Y9c9`dhXT_2ZJ--tR2C!VZp3&Gltx_!q3k? zej*qYGoeGETM67Tc9eR*>H`ejrJ;WuSLO9+Hx`dND5W5{l8C?_D;ca)tEOvW;Jj2$ zI*4eD2-esJ=5X!~WdvEvzW8gAf3}I)ToMOlQe4XiVtg#;qpFz$&(#C&Mg)vrfgQ@nb4mVYh-p# z-XR@(!#bUfhOGp@Fyl?;jfL1pj-SZJp7q(eRw$NJp~>o_OmK&9=fIHS2msi5Q71Ro z?vM+9DO8X@&Cj2A$9E-gQFKsR`LFB;sRI4dVW^kw?Rfhi1HKS5{=<@cEr@m$y?su@EM|Ziu_c`%Ej7h-ve13$*qs zet4C@3OE#0`}(IPxYf3_^X)U+H*(S}uQHco61bEc!vE0YdktHL|Ac=D=`QN0FD|zZ zVk({vuRguAXS{dchQMR6a%{z9-Pz0SNXPh}?U*jhj2|p2!}MGV2F944k=~~VGzk^c zqY{!{8IS|e*p3j_n(+1luSzbXkMP;{&-se0QiI(+%);ScrL#n8cRYZoV^CU= zENmwI4scf_rJWmN$F)YOm2CwHl+H7LCG#9~__U5tehIYG!dYM!KU*%9UW z8=xR=MR^5=xHNQ>X5MZR$z*1b4mDki*CP{lS=f?!wij|&x?bgnK1zCoEbn6g&2ZprZ)AxDz^ zF6PxhrPAD$0hIEob>)w_0aNGL-kc71X2xFP((+2KVztk_SA?VNF)8sr|V5R zOP#E4{|^akYaf_uL^r_l2S8`wY^LY-WJMc!n$hYkg3Vn5IHa^ewho3Z+6gq_hBa(l zSNIa^Sbz{Q^d+tS??#|WF$}(1TZgF1D$`Ek>o00FoMp(4T;f5l$3K^Pw*B8VH)H*H z8iv}vw%g9kO|qP>m}HZG0FBSa`Ll{B+W!i{C_oL{c(GKK{LRX>+a#2O)YACzvyKrn z)u5rQmcprFJV9wGERO>c3l{3+RIvj1s+Q5;`N2li|S~;@Ufa)a(AFS&E>9u90~#La_Rd@Nv;&Vpv!o zAhGZ_oIlScp}8}e13pbg#JX}K`<+L%M%6>TV&Zw+Zc;iZJ=Zop8Eg_nj<}*jgGIaC zFTDSG42^q}i&aACg|;GRHVu09KHj$TC6>c#2BW?n4K50R5UJI{&R-w7<gR%0M+EFLDBvHq&#%o_8tO2>J*d`*1 z90}d^uMr7Fj1K@0CS|U(o^z46pkmn4jEaORl7#gA$|wN2Q!U<`UFC%er$D0kZ0yQ~ zA6?J8K>-es5aEADe4SmJtYUpB7aYz8k2yUoz0o>gJ9=JYa_aN0l%DA4nroDzaDXca zLz-6zKFH6|kK-&Y8eM7nb-c-jipkgjzYY~Xv(oUskfP3()|Ds+gFU`tCCf&dOp3IW z+ho;a*yox=>V|Zf27@W~e|!)<$WH-~VWEm6&JkhH4aY5BO>wua{_X5tBVe;&DvVVz zHVPxJMhbr*a|oQ>z5CXkWAPx)alX*yv=!`>iPV6_6g4WHB?4kUMNt{a-F}MX=($zR zo0wo(ehK9m-)pBe;TlXGZ2Pcy&ERe&F}%ySp_-8A%D2&s=Zc}eXhggo&97Bs zmt!PiFeRxh)PtVzZK9RkD_k%~j|Mti8fP{xr}-Ko$|?EIkuvYLD|u;~d}kADKL7w= zX~q*Q0|tdiZqf@L7V%#zXBAe~0-l^*bAxy8v{`s-NLsZgUy-!ED4oy8+CFMrC>SJ{ z!9n?#tEm>-)2SeFmz=>1z|Ev_`8i2e(!_~?B>65Ubr(sB)Vn&q_}{i3*=Ct5`K4;9 z8*O&vDcI^Of*BsKp`#}9LcbXk?f&F?UZf?n3GUE!F!+0<$B8jpt~JGz#4}EiK?xj- zO7ciUNfKee>fj=RE>)KFR(4MWB%&|=XlfcUs_NNkq1mIVgpj4_&=Edt8Gb!ZwOCIM zq{bMhvS{8+52|fnq2hN4Pd_O_3SVN3Asll1xE(}9m?-SZDwCgNv^z+bv#~v7 ziHp>$NLzB|tKd(@lC#k1o%);bXHQG6_!ITB1WY6NSLfqvLjP2YH~67NE_E+M5T1bX zy1yYsQJG8!n;5cX?}P6NtJM_1Prb1G&(UZ~EZS>ST@MY1@$cBa%odhoJC0F!n-Z96n%BZR4vk# z_NTgx-Hd9{<%l8zaTd!@^EQtwR1<`10Ub=co|EEJZKk)J@f{V_4u-G%Popmrb>@}Q zm1)smNV3%n)@DC{ett?4`wwfN`0;~gM;SiUVe6=-((1K3{GVvs;+YV9i3{kCk#$h? z!=)@kVaf;3NZAsj5}tPzj#7*Tn_rrppnQ(u#3|g?_WUJ6MDViwRaYpiQo=E^7R*ZE z`XEKjROrPxDE@`1P}z0TRIv1WB~yX)dwC3U%`C7NioMF&Mt4S$&y+D?J2kIQ)=usvK|Rx0uvN$FnCtRnh$jj;%%B@gZ?OwT zQb=3UY!wqxleX0-iFH{lHfhjXa2a#i8yPcmtFUXqth-26QujfX3NJ>iJ7+x=SaZPE z!6PV)xu(+q(sQE?gk@$q!y1t;g#&~xh<~F~`n{|?N*8PXA&>wbb{;olw_X`h(N>Xy zqP%+LnCEU><;=0ckA(doR~XlKP#nkx_yTuwny?hjgvhD-A%17VF1NTsX%!p3RB|@_ zEJ(x9fat2V_E4w%gOW~7nV5^9Fl`d)O)xH#M8lRNWtRHub^W-U%4z!^eqq^MkBbys zR_lY+%!JV3Fo5C_c%s)1cgB(|$ zW~+q`-9F*RlH54u&KKfAq{BBNN)-#=kzS`>ZPjG$qexx#Bbn5e_F)v*F)P>sXy*KC z2zoN%N{dg298oO~+KOajIDZosd_C%KT@ssx!qF~3;OpV#BfB0jGb$|q2jM8V*TrcC z+nM>ZXCuQ6QA{p)h8i{4!>kY6x&z~g=?}2F>uV8{z38uLuVv@vIAN-@B2^`a`+ABX zG3%*G8_>rwfa02^_~sGjjK=$DT&Pk?-7U=XHWc=Nd)fKu8eAi2TbH?nk#&n9LX$xj zmOpWwM~Cytj2Q+^e-Qu3fOg-?wT_|Ig9YDA-`cjJXc z;`24!5O<;Q9kZtuE_Q7kjTF%ag+$9D6@8PQ?j&YA^!AYfbMr=&5?;(&>$1(*R!%ID z^P`R!>^fwdsK5POVEkj4tDzyX7GxY z=Z39otMiPz&R;x@4K6xpbg$l%*wIUmjs&biCgwkOkhYd|ze%J`4|%xiy`OGLcOCS) zVswSjheh7%BfO#1rfjLG$AGWFZWu^g=m0<1a$C8-f#@qGZ=3Oi9~|FyKWZoN=g2+F@4zw+zG97oJ<=kd*+6K*M z#x=$YsYA=35Xy$TwFtIF7C#zjJvHec<1#mdfn84FCvAQoXipicH0jNPn2*)eboUy5*gpoZm)X}7h-X3IFpQC z*jLV?3peGJEVG9Ya^BOkMS0X9o`C$h*vijhEw=@`QX4tRDYebJ>@C7?EVOh~5&{qU;OeJ{81;;<~^hnI|R@a}uKA=dAcudiN0+Ftrz z8E?G{d!Wq^{m+lr!w*shVb>PhfLOjC;BZE-_#A&1F{)+B*;kKSv4n-RL7t3RNQ=fJ zoZFkgE?oC(w@$WoKI>#>p(sY@(XQ`()@5O$T9`Qbv*zT_;h&$3e*zBxn6$KuwttZ* z7upw^>aaS}w24Cb1Yb~%{DNFz4r%Hvc1VXf3b`)RJ8~~?#0>0}y(RK0{Pq{B3d4ZL z$!gF*y~PZ%m<@C>2jUW$9&$Duz_2cp)6H!$+JOf0Lgq^TgZt=qP; z&l0tT`QWgv_gR6ljKuew6Rm;$I}D%Ah_(61XA*6$8YhXet(zLn6PtE*8U#gx-k0%@#J+kizi)dknF|Q9YGP1G;Q9l z5%?m?q5L8G73`3|eAQXPTIT`WRg<`B!6q{~^mf`g_#oSVG=r^Jc1X(2aqs6FJ%4+I zn&DqZGZ{MCe2LGULEzowfq z_Znj_5W~g)UQg>!+r6#MWqsd-&piN9GT3 z0onKPC4bd9?*T6%zbOEPFBY5$N7^npTfDbaX=3PUT{d_Pnovf?9pat!R3hal>lOul z9N-tT-ldLq@Mu&{A$VnX-Al1N84S1hsY7IfA%jvTBm^5uSjq;q6H)gt@?;U>??28a z5QKg`+Bl;~Yv`s1dLD1t5!Gv!QVR_v3=B38fBGbSd)+_deWp|od$+CTNr1I1`>S1lX6>M4tnGR&e~rCay}YtDG^7r+&F2P-wg5FmO;zCT1+F>cxTVN9 zr~htvrkvMt0MFy3$eMTfKAiS0hOn<55r-up zvtdVD8aqH3pi;Lh4i`xdWnuu&NzS)v6QkRQN8pjLXRDNNMYw^b9^@wY<;H*>hvg5Q z5gT_^Q~FxzUvUhhJRM#to8ClF?!7#`LUXeLp5R6*?EaRSlv0}H7{G1i)-tuqWI!r` zNe^YcRo_?mms{eKEONT!m}JjV={B@it{3~(DK-&QM1#g#W7x_^JT%bun+Uq8fTNvb zNL%q2_22|6jr;FlJQ4J)sMXYI-l~sMiszz!ahwzip5UEvs$m{1Tx5bNN$4AFtB_X0 znY*k@uBQ(i%%Fg?DmJy*7GUQF7(Nrd14ax0ZSj=nH^TCr$xT$Ec+<6VKYI5u)Tk7Z zC4x}ZA}P&E(K76(( zKgX%HLun#0aBGA48k?Y*YS(UKmnQx%;g{u=P0*ZTy0r z0O&U!;a5gyokUT7cJQ{Q(T0LZ{@AjPA$vd;D~q!$-8maE?8P}`X}O~8%F;c!ybIVl zaHkSj@Ihq4dD}*=WSv2252G(l5H$5d+H7GKa==2*OifU;J>c6E3f0M~C_KJHW2Pu_ zL{9{>pFdr>xK~S1>-*cPQR0l3WFF?vNCyuiW4dtAkF}@R2Vt>A?@2(6Sf4U=MXP}f z!QikPtDp@0Jm|us!V8DS%XK*8db#j} zP>3thGwx3rvN&uaXFp>hfM8HJ+k#!=I^7*M{V4&95%8%AUiZy#mc-MdG!eIoq5X=n z+WnC}a1+%#aiA4EYZ4zp^tM>t#76!-v5h{t8)Mt$kQKh9C8kmj`-&weK{>jnFXEl-UmE-2S-CEsV6u2Z6~v zRHZ(ucQ^l56bH3;S^x8&=^Qt{1a9zl@hV_4KT3OKOo#={pjxY_l=a|HXVr#nT10#O zq!_t#9R2?c7H(8mq#R^p{FZmHF>azn4vCx#9mUv68H-oiLmf_S<7t+NrbtR)Jc{9D zI^f3F8C%4rml$_6LLIx{InMUxKUmO!gh>{PVQha2izU*RVcBUQs_-$=D*~JhHK+4+ z<#hh7Kg*#TBFI_zm)x(*zYl&E$EAa(mDW9l`NmEU1mWca8odstWR{dMhd2PGXvZ#F zju6LUXC=p2=0l{hp@6N{GbddZmN8!f(L8Pprw|H^WZ_x| z3Xf1lmH^J6FBjXTU~zQn%wuuxlE;x#As>tujSxQe#I)MA-CK@5Jj_Wu1D!1lP|;kjYtwm;yi?PIXj+`Q~1GGkJ@H5)h_&9#?GV*Z1TelM1G4(UMTN8 zs)q}>1BdcSU3y)oR(F|$n6G=dA;VJL#zD98KdoXnOd?-01KdDl$>QWJasr8s>qWmB zFd~d(B`J$v?c-QG991=+&!CN^SmH@%6Tg1IJ;>;>4WuD2IIcQnJSg=$t*Fm2Bw6sa>hh;M^3Fpus0MNz^ z{OOg)cmQN`n0Qv6uEp1Ij&TKPW>2GBM&(#~eV9Evc-A?Z3c{6sf}07Ld6^YMMSud; z1FDCX`uRTT4*>RixB>BG{vaOqDbb;C?oP{_MW`&w%I8d3xY zTzi5hf2T)~hu8QpvP3aDw4IG{W+R)kSaOZCJ9>hOd%0th8>wye-Y>RfP#(YN)u{%e zRkFCA@u;t8{y*2>u{hbrw2l>yIB)&Gw4DolRMoZrGmt=#;2AVPRMco=P1GV-Xfp-c z3{G?gClD}ds8qR)mm;;6+N7caqLZ{thXd5wR`1nnTl;R+wqB)b+dO~(@(3VLMWdq5 z7?oEg0g?Q_zrD}of#B`E_w)B7ne*6ZKh|Eaz4qE`1(hk0`Y9E0qT9;?uQ?A{0U9c5 zfbE>7O^I1}aF+SnV}~=fixdj51lQwo=i!F)k%8y!hq+u94!lz0JhZATu$@EQ&7lFt zEGm$kM|2C8rrJ^o2W&vB66cXsWxnRMQ=WUDzV9YXgJk&5?|9KnB0vpSmN&IZ$LAY;j zfz&?YvAo{b6y?l$1n^LHZAtBRr}j3msx0tgFutER!R$>=tq|S}(^!ACBFp{MRc`L- zP8n(lL&7@gAAVLizKtC%_Qy7J_9VXXDmUj-+>oQ_XmHcJk%m2ZbE5yU_2thQ0IBq0 zL+k~!Pj(sGVqm^MTX#7lqdrWY(@3MF;1{R&F?(f~MSbtEW1D$uB-Y?B3#_YI4&6#d znN%RYmcaIE@}c2TgkCHD1Zo)N7E9G=<3`V>b`I+nFWAXJ^*Cn>f2ZYK%$pZ9*YJ^mpK**elu`sx1V`YN zv(^rPzkcE?r-#7tM>B*zQJdvs74pOvXr8}5rBzs3zhLRfUMI`RAJGb($}j354neG= z|947fI=8+}q8N0-IV%uA$Ff>GGL)dmv`by&ELyF{zvVI6h~A5nb7sz(&e&VZLABb= z{d`~pySP-2yjOmxQJILBiG2cx@4m#H(3efB&awl0ixZo?4ZU0aHnww3>-G3Q)^WYZD<7cISHkE32u%2>T6@bl0r!5Dyb*- z2P3wWZ&~6i9J_=t;=ZPE5fm!9#(wHk7NY!Ww!*$z>+}(;HN=n|E_&YRhAKG6E0C?4 z4Ymki}r}ljc5p{u4 z=BqfL%OHhIwI)8ZTYfP&1f`#-|Qxi>j?-$$LJHjg?qsx#@n|51K@&fLf;&p% zdlUWZ>O*e$TyFP;oXF~6?6uYqI@3Q%TtYjr>wh8-aEQ^WH5fk}#D^pp`;geLZwei$ zBp9zRElP5%*;)F1%81;OWmWrGA?-s~T*)I9+ouy&9c&1+omT35yVSQk=$3F`xW0NC z-?Qi^z)0*U=l!c+3*mONZ{Du5s;!|oT4m;CQS4rBXeA~RE8m2LIjfB$M*3*IuOo1v zW>2q*Yku8h&tCl`$$&ikS|c{PK~ZCfUTY+wMh3sf^jqgr-O;AcOc#S`csnb|GrnsP zD3I-3zH9;T00p#5wd3w@%cFTuh*p5z-nJpkQ>m{t_U^@|?G-7#w^D}-;q!xTH6 ziOss4PrlOBCI5Pr-^eme<(nz5vYqegyPBW%D)a}h(9gX>eM}#my18gMy$ZhQ6}-bM z*g$W@j3ysn@By!2xmU2#H0#uT`uKt?yn+{c1%KkzC^w#7P0xDQ4&>Ne+hpJ4Ybx~$ z?52Q5TI$vGm*Z=y-)n1nih^*tdInItghKjgIh6p)ZeeBkhsQeP*<)5-{RuK0Y!5f>5P6b}=0{u~-Vt z1uM{ndcZn&5x=Ro`D5rKu%r4cgzt8kafJ>&(0y$6dzE+VPrv4aL?#CW0y`FbO|Sg% zhN7L!+?6s}qDxl{8V{;rrHmHLaqhhXc<}OqohG9nn;JBx@C8@76_;kK&nA|EJLr!0 zRqlpXxQBJRNM8BNbW6)j58@4pVc6{^tyLPG->Kiwcvy-WTe{bviy@xmE?c6NN@2ve zDnfJtt#1_mvC^r%oGDh%iC3?H`ar3O9f&-cgOO@=uSzN1Ow)EIXqk{3b@kZ@k_Yx>G>HE3klZ8pldLCFNm39d)nV z7Y(q9d|d~t_IkWgorhUNw^YxG9qv>8bvyU_Bkr|%n{dzePtKN-Nw_Um1Z%8ZK*f|_ zEAFB0Y369$ci`b80<*z&?)Wx#zhASmW`lK>UKP{%l zQiKx~LifeQf-Q$-LOMQ5&PMozzO*{x4Oi&v33!aJtx2Vx2P8c>iiz)GRFSUW+6-SC z5BLcdimV_W))`_Y<*@2J`O`5uJ!#&+UD}^C?MQrEB)-nb6T@broR6<69#vmP7(yqE zjr~|yK?RwNNY$ut-652oRY;x7+L%Zhf_pU?^~YL~k`I5|FxcAvVjU?{TWMkh3~kAG zm}1PkAJG#Tzr{GU$T5nv>XzAu<#8Wb;N5Y%vxQDPpA~iQ=twUM2@k6lD`j`#Se9{Y-U0?J}%cjA)KFE~pq5LW`>@ zXLd>4tXrrXp7b1*0jFQ{11JZNX6-coNp5Cm&(4{hMT@Gw9Eiy9t0iZ0%U@M{t!Euj zj|I6B+s@!H=z;fOZ5c&@4b%0ZCWnp7m9S6dSm!zCiiggTk~SkuXn{(n?o=o+br^Zs zrQbMp=ZPxaT(}hLOI#WDCV%t#N1bg?TDoV3uFxPk8`6aBK^WfG;tj$@!u5RN5)@CNDi(p`ykzS1dpv zKUo$I+){2Unu4B5^w z%XjWDQyZ!);f%&MxhLprA3=TD<28=W99WFH!{IM7B5x@}VNj&twZ_)dzDs1DPXosO zEm8lZ*T5{XQZxm&pWI0uDh5}u7VoyH>2bX*$B_AaAp|^CjZMZM-vC1c7Ly3Zce59#nRyj*8Ucad`9RH&13TvZyofMbc*KBK zHip)Sc6ZG8-W2b!ktLGfxK;eZ-dJAYcWSlJPGIqYaR|xt6wv}K zS;Sb1)`kdBUu6!30~(zT8y|RGoEx` zNA8L=dl&j9U*i$Eriu<=QwF7@9z}_e07N}sbP+|>wl0)T^SFqwW%hvU%EN%bAb^`S zj82y0A1D6cjxXNB_n6YdfWL*E%=)Qayh{;{q-oJFwUWH`djgF%NI(G2i{4-Gq8g{7 zFr%=>W4z+O7(a#_Sx0 zN}+%j)4hMZfs|DQXN=Pec`g!1k)b4$&p&0`3&xK6 z$Verk@+KfoWAZ~^5)68x z5fHO;khw$XRATVS$C|hso!+B;g!A~{gOEiftH~nroIc4 zK%uBR8vItj1oa31Elq!%icCeBKnrhW)iU3f(#PQ_rg zSOxDI=wX)ggcN<)v%Xly7h#`#hr6*W^{|=VT3#8`&K!lGPNt#P0}W1xVH;{sU4+Q9 zSKkz;?^frRg%XZpjTk@QvMNBkx1ODy5uwc;&i942PTgAm2Cr2&5hd8XFnAS(>o{Ey zW;xL>Lh@jxjbmH5orH`n2t8O~CMikOKc{X1e~tZ1BcY|RJF%mbK()pOhAvLRIUH^A z`70gu65-gEsqxHBL}Cj%rS-M-HP@BazE?99w`fnUs`3V+8U1G?1zPIr%`PH36DNVH z-v|aiL=$*b=X!mq5Sdv1R2tuTeJH;AE5Yf(uLN&snz@V{Y#}9J;>NZXHpJRmdq4wz z7)tb$RqT#%l@A33O0C*wv{RU|6BfDblS#WBPcZffMuZMz-#Mu!8m@A}#Mt%iSMS!| zIj-gl)UjZUVr00vx^8v29^D4StMicVnIcECG%!k+XQX&ZO$yv zuU5DH+~sM*{8C%-#$l zcpYvsI+C_c#Lvz=_*S?xBLg-Ndlz13kGN|mLL5R$T((tg;yDEdhZ5v*QUh9s`uUfq zZ;TRwE?S5x!{R6Toqs2yD#(&yzLg`aJLbP$Ms%)BUe7Bcppg18TAKKr332(PS^~P+ zI_fj`8^&fa5|^k&8@(4K8Vd#X->nqU@fUd3+!s#Rxjc)@bRHLd)U!oqXv|1j3?)V; zlQ#(-H9u^YS=AK>zulZtly*TIcdpc$ShW$Lhh&eF+xUxxBxgj^!%Rmzl5o0^{Ms+RJ$&-!i?C zRQN2vxOavK>tB1MPez6zZNs`v`y2_aO)zaN&7)>dLa}@Zgk2in8d&Wt{XmFM;BwYZ zDDE)ZaNU}S6XvIrAKW}vM{xFNZ;7;TqNchj)I@|01q;lNx;GgW?Ce{%^U!$$|MHvU z4nsrStp?wxV>|Kf=H^xYb)*+?Lco!%7+^{$8Cma(P*8MWDTQHoIFzL(rb~~0sNhlE zxR+2?`40i#1Lnc-E#cT+oVZ^O#oKf$gw;fz4$>)P%1?o)YO^vRc$@0B2$h8qLz`yf)~dF*UWyY!lyY;J31e zf3>WJ)2WesMskfPDB|n@u+yL`09>OCAL@U4GU=4@A?4J~@xb$xu^c~VUjQP^9S~yb zI*@z`*INU{d;>)RkQr0#fi3`Y*y3XVOs{uCMcae%kHB76`2)2d}&s26s{iv5>twcSm zFh;uY!LqtTi$VpLW5hcsQ<~p1;c{RC#LRv3n z_j;SR#mbKv>@y^PPZ8BorR~)&@vzt;4ZE+b7({0bg6voe$iAC)sR_HRj5(AO-~hK> zS2@ug&}uk23q}SKhSJs9NOfO3T^+W|GPDhC4`fetFTp`V4YMcBue6I0htl5y?Xf;9 z1D0|4s#lpf=RTL26OhERY&AaS_>r%|`=KqFRmI1F(FHZHnoVfCnmhX$sv$hi>`WGG zFJpy3^Ek%OY__7uB+dQ!gSyX}oduD1&`9^s4tuActEE}Aa*;eongu}8jRzR8w45CY zazP$DLoHMkT&~vDEDOp(x0zxG z4K&4)nDJ%negG{FK3R(=9O1YgE!v?8^A~8m6$K$Q$?v4+O2_8e2?rnSoJP-h8;`wJo`Y21&J=-~_M&NY#R3wdGA14Q*zWq`B zbXFhFK-1rMBR0eojSt6AIVKMXB)3dY(?@laIU(4y ze2_0cPBd?ztN@C->_Jri9g2u(UIM4nSS~7f6gVj$i_o|y1 zNoDWHNM%*>3_OSadm+;o7o?Aq3V``vkxC8Xxowcq*Z((k@?H4BC(+3Ws!!9&JQxYc zsC0+gOF47o-$35Hb8;1f$KHuCxS&+(uKS}fE)!N~|?{y;T*oOF6|gXzo5{20P` zQx_-d(g_K}|4HpFVlU42Vq=co4rx34fq7YNYeyNLAkHT>$@J~T^8>iZ#Nli zX2H~(4C;CEe`nbv%`5dEHA3 z>u6IU&z8*+3;Xz9X<=5nq_wckl#@73So04hvuV9&Q{LEl%&oM8XQP`b@0_W`w+w-|Wqe6wzI_zTE2sZVk{7Y4L&d8n)P6mFhk+NX&k0v$qO0X%`Q68l^}Gl= z)A3tm8A<&42I9cT8^U*}G_bSgfz*dAJx)kJ7p;YU-kfUbXRBGDq>WrwA%lKSAZ7lN z>?visiKzEd#-&tGBC<=FUjsp7p6{lfF5-YL4HfYfF8HYYXP-d_4KWGp^Mf3VV&w7l zavvx$bBM~#8rz<1vbr?pdCqQyd>x`6c)vNd>^uR{vMTCFrOG_JH|fAN3}J=Fjw`5n zD$O{$sf(p7XigvgxTcG~27O5XK=s%7`5y|P2l%9y0QxT;^kB%HF>3aZ(wzK$fRUv& zvpyaf^dP!xY)`(To@jA2Qy2d-(f#0)S{vq9%bs2~fO>m~pXO!*fL4C~N8(4{^%(8o z9_{xe!6`OOS=f+asAz|w#BtL9t5)|QMoWO;c~83RMTnkmhLs0G@W?VvgFT27GRgOd zlKlqbjem5YMtDMc%oRO0{@>~G>-gsD6%Za=u4PtsE9zLnJE4*EMkV%KASZtlnbMfWE{*%NZ@R~Bj*Cy`38NMkx)L%Ym0 zGe$nvhD0tuS$j!F`Z4>#t)JB1YqI!2B33TFxq=oXm;S;9<7?DChLZ7{bn!2b@aWy$ zBQ!dh*2zo0h_Y_&2hNhqxK6J_{^vG?e@Xx9y&kdp*K@2Yq(xU?kv5_~1(sDXzNRLo z-W_z8hN+4DE%&o?JcS~ySMaN&H{Cz27To&L?v;L%<=1HJ&zl>brI}x1Sn42g7-^h# zO@fMdY|~@HG(`_SZ(5u^fZBV`BDX9X)TZ~-qX!}~wHbA53m#J2FIG?$dO#{qAs=Ob zNVUH!Kp(Gee%MIqr?0Yf`zsS+u{Yf+&Q347eeiYF^WUkPRpeIbMYm?+|2{|{k$)El zmqoEgY)Xc7X_>g7d6awhUizkUsFIe&2udBLmnjzSP@{RWorRhij*lZ;Svvl-iA!z{ zI&;d|>YE*t01Osn^vz4U_05seH`zEe^6+6=N>ldo2F=2tJ^UC1SZ(gd@6`RjjQ5%I zHPDk#_8B?6G)UK_Z+_V{GG@9Ok?8yS$y)1)5nXo3AJ6-Q)^f!BY0c90AXO~7eyN_v z?wEJ@F?4-c7yt733VO8IQ`p@El6C8w*K*fG#QlHMH_sO9I7bn9ru}g6`C}$Br7xy=Y zL91g*-#wu{@JrO#Ll2AJL4#@1JKi36e}7)~CcRhxrVfsIn;%1Z`*d-l4xW(o&ibU* z{wO0Ctx3=f`XTiiplCSmkn3%;bJW`Z%^LV6s^~fXx!vRMNt$a|yI>1U>!CZ19{Lmy zErsF_Vitw}U-ZxsY5r{W(c7~G@)PQ#WF>N@D<6?rACkxYf4M$N_Rl1raocZ-NOksamIUst-Tkcv_2+v3T;%nl` z{OM&pmE64zy|t)OO)=d_dD^d#C4Ed4ZNT8CdTrWHoJ`n@Nr)a4fQBR{UMJM7I#d2J zvA;X&H6J6uvDxEK{TltsUVTPdhY2|5j@j~TPms_{%x(h!Rjs-u&BMYVZFeVT;>n>P zK{_L?=%nq{bGq%-@%C=`j7xX$K33)@ginB;v0-o$?Z-GBi7Cur86@>>nAsgLFv4um z6G*TU0V!;=C$xVYSWm*m%v}B004D54tuDxf+1Uaf)%1o*d+e{KQ)x9&yDHb%!7I6Z|{CJ`VnYR$&VqV8<$zy)FT%u>tH3lx!(SIL2G-5=6x3j)~Gh?=hZqn!DTkq%m$r zD>2yp6O?+(0CEUkmj-==MzlXyF z_2-0e*oDi7o$Fq!p^-ETqx>vC@B_7Z0+j#PV6o~-4;DT(#W}L$DV+&;;lIo%V`|QV zUSs&vEfoJ33RJijJC;yKVl89iP6y4Q~`1sTYv z2nFXwoG!!wT~Lrb4WA)i6cnV-)kXmp-NkpIV*J)WYX~&L_IjZr8-J$hNxi-HBc8Ho zNam6cI{o1v4ZLt`N*-%4b(+w_Xwm>h03b9;MOKU&Il0<$`+T0Pqv6wae3v1Qmizp_ zQ@hF9f(zC$U_cr9fGHUBbl`toR)_*XVl-8*0LHIdKPsxp+VzCGs;6`}ocuaq;<3IQ zJn%TEn0fMN{e~})8zyf79vr2la-ixwJB9MTrJOli%qC6<$(c{jf;tzX;IhDsh|_-h z7>ef>=(Sp!UXZPMO1^iqX`M4n^nr)`rEn-Ah)m-s@3eu8jMMBDS>HBDGMIZ{@&gmF z_(0nIj0Uo4z|?sCEK}n^`Q;Vb$kk>>70-4uE@5V@=JR*B{FH&Hfh2*yE3yXB3N7LY zUNOeUu&I?&9TCl&&!?V}(5V-6B1opoY-`S;}S#xS_r%0<7sQrKSF_I%|H2UVCrUk0ejH{5{dm98^0ob z2t87TI~GO^92i48&OIU)sGxymGHep_-K62QH@*UjYl6j3Pdtn^k5$km_o8#d5_=# z;VKSRIZIwg!7E}%4an;-)=0W;#_9E68NDBf`dZoSY6w@YG*_b=SSB6;?UGseBbuR? zawgoK0V<(LFmT9OtX;Q=J2^WTILHYi^|gvv`V|Fv!S<~ostx(xFRQAT?-E>cod%>{ zhJCL@ir_ALUy>^a2l()L8s}&07KEHb2sT1%+4+RQw`aGF>6#zF#A)|k&e8^INwd#L zGb>weW2Ci;ts;5B-m<{E)!!5db1=q@c!3iG;yHd+a}`<7{Lw&Z$c?`@zn0S}a)h3S2#)wLeFs3`in98gqWhr zaAHXKcRmxGB)8!0u<_ze3VgsalZ=76`18Oa4M~=pvmM2xUT#!E$_LCi zayKfyD5vQ7Xm%zFho>W&w~VZu({v2TP)qXG^@bseHqB6RQC8mbO5+;MI1OE-mIBJI z^*iSY+I5~_gU%D+2#Zv{=iSw2WOh+17|xZ(T@0Rz`^*Yg<&6R#p>fNc>d2$%nZuoM z7snym=^q3k{v%14&=+69&C2na7p)pxR<}9g#pkK?7}$(NpTw}f{TOSA4-K=!?Q&8J zpjbpD$)7!I@(XuyusPa!aAlG4QeOuX!@{n$gqgS()^e9p=&CM#pa=^sr)5XKY{FUs zXy&()=4eEWm}9g!TPT3DuZ69M70DlkN5-=!}qkuR}V0!UUsYGIeOJiJh-U;VO+j3;t!!D6m2=G=&7rtnEVtu=}%tSob% z)Q2p(&Y726O)WP3IvuyZ0-P`htu(tjX1)XDWqDsgnv1EXk1|TDQOyiJHI_eMsAcX?X(m(QoLCMh17js3u<6aI0ik&4t%*@EB<%mRr zU-6MyrS9!!7b1^FnbWeW_d`VoOlA*iO7yifra6aKTuWbZk%XKwBW|e)tWWq$yjp$i zMj$Jb*Zf?yO2SZeo-+0vj>dO!Y;?WOOG6>}=(Ol`Z|!Po4Ea7J#>tB~!g9nE+137A zzOH%+$;I=Eu~u$?gfB{7J^NKvZIL5Nwp{wE^|YZjC>tjhqRtSUVMCbsWts?0zxu6@ z=bMig7bxslqzWO3N+5nPl0$9}Y8Or~65m4X<&ur(A#?IF@dcqpQ~Zvj3fhtRf}ZD7 zEPk1Jt~!d-Z>EER92Ut;oGyB&*5Sn#K^M}2A_B_{I!j{%M#W+GDT9>&Hr+!|=BWI- z?g9HCFySmj_44eTDUypkoT`i0xBy8i>4Lb}NFBu0jX5T4NGASHvf?Veh205TaC=ZE znU74(M|PCJvwprHjL71%@JkeZQ}IG7hT09Khm~JvV{*P$JR;}RCDwmYXqZoWkDz;Z zA4tjI19cKEt`%fMk8 ze4KCiw1^*%afvs;#;i?4lWz701g1*GCP(j@4rY*qz?Z}YJ3_z9q1*3JK{+lbFLy8j z!U5z+H+dF!(X1OnA`>HfLxgs#NQ^;C%4A87JyW5{@m6W4CUrTG?c%pV@}R@TmtM(3 z!P-O~1wV}d#fIowO%`F0G^vxb&YL}Kb z>JSnr;m03=;XMGfLUF^fW+gHvKtl+_OwCAsVqpA*qNezcz!px4De>e|c3Ko4E|ZAp z_4L}EMMmnCX|ZOQk&!LmrI>>9A%ay2W4Gk^KCl$dyEHfk9hu zmkJE^Glkl3<&%X}XS7*(6p=8I(fWgSJsOYkcaqz_tk<<>Mi_aiv}1JS(z?#Om!Oob z=Ib8k>lj!jnM*bGQP5H}k;YOC=2k$PU6h@eX%0TdK-@tu^TSdF!+r+&V8QJ&9$=}f zT4O9lLIuklU{;S($gBeBB6+z98kxHV>*!`hd6$S0?wDVbXo2%IR0Xz&Ug$t#QbvS` zh_mW{^3E}QAq)R^QR_I*8;-B;T8+itoh2TQ!Ym$NA}z=?E~iSgcNY!z z9y9H;nl>>y7JY@=y3OX8o-_GK;Fz=chdfcNsYabIs8Z>wSHPm6XG|Dvg6qIf*)*S5 zFkK2(zNH&*rqG-(9{oz#o_HdmR5-4jB`Z;r+t`u`Y3x!O`l@VfB}Zq_F?}nDQZ>@4 zJtVO4Iy*>4Xg^6i-CH^Nl*AtZ{s&W;@(an7PNDQxXVO;sFkQtJKFJ)*&uvM5(fAW+ zbbiueEw~S*==w)MZZRc}&6Szda_F_dY&vqU6EedcO!0S2!%S<;P@aqos4fk(F*;PV zA15iGSc#&GhFe`w?)}S4{uC<3l48>oMz5Y?`$e`+e1bgt;TpdiD z5xh9hM0R7b68rG%1tqZ$$2v=tD)pWZe+0ChCD^LCF6*OftVCQtGf>xWo9j8lI5@hH z%V#tA#wly0;+*Oze^0GGm%mPRA%6!EE>R8MR61%;tYZ+FSyz<$_5ctfytiH-WHX%c z1X(C`Kk4QN!RHa2!td_FYEb3x`S72#y5MQjE0zQ|9c}xgspom1+u8OrdrtKh1M0o? z2c3(Wk`4d)QRhMDhOEOsLo{U)^nioT@f{Ba+dG~;g&JcWr#R6@va_Z>$5$r)UFs5D zmGClkK3A&$AaS(#cPdV#g)P*!$+@)AiAi8Ng}X4gET(ej(w$E11HQr-=M*LnI@6C( za<4ODJ*nKB@9)%`I!>nWeg`jhoAN8o{c8uE$~T=6>zwZk+D;vdCQ9w2)IXg|S2=}m zIWeut4m#6bF<&jUH*YzYu5e=aa+4UgoW4M_)wer^|HO9Z6t?m8LF#>%ueNZ#f?wL1 zw$>SO=+3)q<~t+aGe`XH{CdsJ16rIB_4e+XnyYoU$KHLZX1wk;+q7$tagOtJMZuZq!0-H9?8q6n*XZ`FSTdh8j%N~l**@(b zOXV+$7M!J*!;gPDTu;wF{^{9zdd~4rO>5^K|Mc8Zo5x-4ki7HIxKN36|Ef`I#$AqB z9`|ME{(4|Lpn-Vmb?k>`aCW9n_+dRRG)7U92}%L<7xIQzXYjY}4MM~QOk^czk`F3? z5~gJx{V5nkuF%%D70ZIpL)#f`&!yMXEGCM0txYcTGycPe4f&;^coZmV-YDm@<&LR< zYs$54qrS_iFEz`M3wRKGUWS=eW%}NECM5V(7o01opRU`pOBPiZoT1xc&NEmeW+Ik` zFxP!-K2Wa63@Y7l<~{QYPQS9$sapez&m5aIm6n}ahq>hD^XBGFdy|4loZ8Gx^QP6@ z{L0>JH#ghu%?5KbE=vQrrC`{ze5{c_$K&Ah`MSZ0`OF7D>XfYe5#lvn;$ceY-LVJE zySi`lF8F*2U!-m|#+B~AzQjYi_kd}t0$_79(cD~YZ-VA#g6(**x!GfHE;TnpY+pZZ zZtmm;Hk!&dt%Rt}gGucnj3Vad>S<10N;hM(M(LZnm$@nV!WdPs9NHlkU8ptHY-}hc z40m3^nS@`dJ`IlcbZ);zx&5USh6Bml_E}lv+xz!?zLFIxJ6!Zma@UVOVhO@cYK!UpPl`hYXE=4^cwoVs3aX!~p?tDa zhviqmnMXmQsM$_`%iQF0lX{3D3-L!W`7~xen>^L2`-om}zi?i`uq&Oqyo2idb+L_*f8m@bU=WTCsTWoHXbs$y6GtB#I->diZaB0n_d(r+e3TkQ!z;dX*F2eVz z^QehAtds6*005wBJH7Foe&qzG4%#xL)Wt)drXCBGfN0 z9gB2zY@oVZXuEr9*VBl)yMb5C=}kO!>K>!-sii#TYp1K+E|q)7g5ZOnq(P9Ur_1=- z^tyb4A>x{wMD$%f&7lsjrZax<--y+aluX*YA?;^gD;u@_trnq#(nWyg~;tcz=SBK+Uj1D84@x4qT zi>izm%nozMNd1cGX@!)JfwZ|llPsltq*+Sx+Qd;PPG+CmGrWO~Hgn~VP0=~5Pm{@W z%(Y*i6{bJqI23_VSRrG}qt4+$_5k@s?ZMEjqf)h-%)7e!xnoPovnKDjMaOug)l{|# z-FymZEr&ZxNRg_}F&&-HBFa#XY!I`yVbCov0E*=<=@%?!>s2m(D81U)jkce>hi+;y z3>U^5OhobY@oSxs`)%`s-e{q(#m^k7wvA#F3`A5&u z2aQIrKu~utA)x@PIpUHS=jp5s_hV$}gZ6a|7aW$K&F;e(Ki8NCh=!DWoVHO9^MlWo zsIP2D#yU!5f|5NiA5akPXGai|$pPo0M!F)ih};bZ_gAMT(kU|x!nuJ&p~OHF+U>7> z5x}4WG0D)&xRK!{JK@APAS7!4lLy=vV&s)2Ki0u+z~`B*5V5J3jNqaRP)F3T4Najq zCVb=%5O>$9{f&yFz30VO8)$eT?RiIb!rCwMR+$PtD>9$u@p#eIJT7V(wYeSBM!Yc? zXm^%6YOPB2iV2wQHAQfZKUT1iZk5K5;!UAlAX0yEAKyY)6SY}QShjrx6pF_GVC-H| zT$6=M>;`F@0#d_t6TwSOyV^E#F;?ZLtl<@6DE2mkFuRg7MWrb@LnUNJlKpFz-bkI* zn@YVgJ09_sG_i=srU_n^r#7n)xU3Fp+A(;(3FE@lF`6HuNGj(iNx)vWwp+C}`;^)J zXZwh5L(pR^MdkF|`_YW+He7Xo!8%o_XohoTt5&0v+}tk^HG2D0^!nF-0R9*gQn?AE z+roQUn^x;9y0g#x+RfSI^uOZ7YdbF6e{98^pqra1_VojBSlKgGef))B{6%9zNn}GY z)uE!-K*r%^RYx(MV08g&|BY4y4Gb@_DDH+RS_wDK=Q z{jFzC2KBQ*A3&4GBHW7X}arVDaCLGU8WlI95*MASfg)GB?7qvsjk`h8m z!;%C7@@FIu#gAh|rSu*~#NlcpY+#fSBN{(iL$ZwM0v)P?5gE1~>*#}}B^YR)cb>rs ziM%|8SUViw;4J+of~;G9&&F%VW(a%>XLyO7T7$l3%gp2^30e`H?t=&@n~aa#x7#;TsMS%uNL#(nYk^jMez}qw09$!|P_!3rp%p%;Y4}S|Nn&+g$ zaK;=-i#-%06ewGp*d3cjZ5}(lAV>M`&fDVDwel`ng@O86E;0ycMKCLTxDI-ec8bI9 zL$hQ@BnXV2k{af`U_i`awdWk>FD=c*%!!VphEPVOM((*=q0fxb}~4kvU!-sLfPawjgZaDanIVH}X*BgWPqtdESE z+CNYtP01f-N1p`~{p<_wHBDi@%Ae$hYz+BwgwaZEtd^MRV}sI6o|46)oUm9xmWShw zM(!9WB(KAn9BHJ1O}jyrm4|#s#HdD&WzwNsXK96yK0)#^dD}v=}bq*$NVU6Ls?C;>Bk-X@qs_Ao~qGL)^{Zzq1zN3c3=e#{FI`Rh|Nf}X@ z{Y9I!ong1Kz=J|}A|6~vW}m`V7CR}xZ+3s21J-rm{>vVqMd|Bo*gQ0o|A@o$?U0=( ztgMrqo=Ze(1RlxK$D}}0sTp@sQv1iF_zhO@jim%J_TSJS?WKw`qOMJ-mpt&K!OJ;z z`s#upIiR}5B==&9qktKmrpc}7>m!?HjEmf}7tL)Mb3Zl@!{j{pXPi)nV zIZTh}NF9&b4~tjQyS{>WJQZ(B&L-d3aiR-`5@-rK4`c1dxhuzcq&|3FQ%aFMm!%u5 zhvTRDhxg2`dZ0%TxCa|awNf1=t8|Rh-Vb&ZPb*cZ^ai zg;w5qKZ1l`z&9*a4*9CHLhktY7)pdF z>)L0XtMK-Fc#u5J?CsVT=49T*wyaYC|ADToMu(mBt?8$)g=1DTTy72%r~ zJ=G`g;l$_ygw|v?)YuVz06clSG-t@{WOs!xhGD1m3F9VF8<2j#BXyd2 zvCuS*n6WrykO46N35^}`5One!v(r`X4(S9bs5P)`JE$n51X+9FX}#T6u-6{Gfsghp9O0CbuMPbH@J6o7VU~w zy~NT*m4TRL7(W7y#DUN*QwGZk zG1R9t;YPtC0zPaFr?!f19aH&xsDpzDy4axG+%HZI_vNsuNlwBR_g<8$MfeWA!#A_k zCdgpdb(7p2JO`x!?%dqjiG$&jvr=}X^Nc|E{Xr7l~iyvnX5qu=^TISqcz7?qjo50RJZ04cwzq4y>bb%91KzaaSku@(ptg2 zcUvZ#Ji_7;l|T*mSO=!*ja&+^vw!u9a13k)$JX*;S$vhjt?^ugTUYXc9qP(yCY|hRRNuFl6Pn^UF~i9W0uT2H(B~t71-f z3L^Y3ZE!kwUco$S!ZL>@Dhy)n0Z!?vL{|o@44%z3_=Tg~2Be~f=Y|TjS zb-{Q|sqyj^(uNX!G1Cfv{WYgr?!2I%ThXU8emdoGoJ^8&Nr1W-A|_Q2K<{! z_LT)1YEr>Cp}|^@hJ5wGKu7htjQ1*c+)qPpiO+Z4(GZQ~a3aSyjEla$>oOVJT+1}x z!SsPq?7Q>3NQHUhSQVTbTaHwL%H*0w8YSzsgeQTAx;cGsxG}J4!EG^u`1u%EHmk85 z06E7*k$>EXpy5pW=z_$+)E(#mUG|$^`2oL9L1V9yxIz3g2OcJxqhoJ(<729Ju~<+^ z1}YAnDpv35deJVrtAH1r+qIojbW`YB(yf?BA~F!e@kLzXRxr|s=9%?U*Wlj$o(5+Y z|4cFLJ6h$f6=()Nnib=N#DFlz1~aKEz7|SE8`)K~%dQHIeic7pa3j8Hf}4Amaeq5Z z4@iS$9IMB;cR?P6_QbDOkypk)!TmL9B$B}(EKW0!)!ZDtF}Nk{EZ4GaG>?#~cCnUp zE9uQsCMgp*HVb+xm!qce&+q1p3~X|i&H~)w#P9+jRkcRQZ3PsR`x~lCoMrnBp_0Q) z3S-vKcwBVAJ~r?IZ*^*FlO%SDV#ACc9Pw?LokOC`-6(?9A7or3E$~0?6e#2E*Gwf# zMFpMlaRT$O={;iJb~tSWPKI&}H!K%rq*gNTX}_6teu@ot!_XWmS%Ecft69FWVTi^x z=4P5=%AqsdZ=>;?f?#tg13(Ks3PVJE!5eEa?6SAV{@qB} znJw&@6&U8YZ*Zepw3>Q0o13)#tTcn(*$q7CWOx|WeR!H_R?v^+8kz*~o`+8GhTx4& z-TIxXWCHAd8uqj9{WsVOvjH^6JbDMUTuv>@ESRG;S1Dg~m!!yL6p?~>cF$7hQcCsn z<7L~vo-1pQ(sQ&SyCa!W9tiI_Tba@jWqlElOoj-yjmA>KY$(Yu&hP^K-)YoDPTC6# zSFA<%Gj%-Ds(5?L*o2^DRg-D|<2wSo78 z<%Ip=bx!liE15cUK|cL2GO^OVic-!B(?f_b2P>mWuRW%PHR9%^?Gid(ABbLTwbhFfFD&U9~k#F@~b zi;1nygiYjT3bX`qY*T)sp8l#(a@LIoO4~exxKt7L=ktW-Hut)A!tPRcL0~9;Z+Llz zKO+Mh22U~zkkkJAp&+I8t-O|p$)9{1mnE%m+LP12WiItmRm*Z-5@VfA>*1E<`L})K zZ7a*nxHtJ{O6vDno_pEbH_jn@d++fo-}-`y;i^;W)-1T3?6K8Xpqr1{tYhd?YV5)t zMWTJbQVt3}SXWNvfl2pNu@=w$1~vt1Qn>Aj)!7fYVVkZ6_2lNwzyICuE^6pJH{9?} ze$kP5vzt5Bx4CFLTiUfpC{1nsXll?~)%vmmul~xcBi})H>GV}!&dX~#-(Inar;V}B zKGmc21VNpC(zp6tJ<02Sl36`SPx5)<^$ll9%)}WO0iUHSzbje|BPIoI@_Y=9RphcQ z{LDmyY@w3Am`FA#*9VDiTe{>caaK>`-$XyjXE`+C|MEWS-parAe9MW2A)C40O%GeS z=LEivDOYkzf5;ksIoGVi)GyXM&1C2F*Y!ZBcq3MvZjCfr#UWX@`A7{y99;|fw ze;3o@B#fM_8Wl8LJyJD5r`Bpw8#C$--7zpoGI`{s&WvM=j_VAM*?%Z%cAhvKA{ljA z)tWNA%86KxVS{t4M(e-I%~?Ik&9pAE>G{M^?++`_X2iFTa~G=_MMS3$A{}Ah;Xq5x zt4fU?l3&lQaKNTzpioUBzAE-s-|DdG({Je$aJvXltX90*k=lOei4qA<1BjIy(7Li? z$NE&~F?G?k9T9gNt(cZ3tEI^uv5vkAZVFdzK#SzN`l5Y8#)f2{h;KDAGTy*8IBQBC zX3bniQ_((t{^pwKxYINIYP5g`r!gCfhfw(f|6ZigXojD^xv;kS{BU4(&5EWbBQsLf zjKszPO>L2`)lD%omnFVL+Oj*tRi{O&GAx%MAZYcs>NX4N9Y7r)a!wPNit6h1@GuWo zE8Z?<0N}3l%LJVT(5qzd<6zkuQ`nQ=f_F&=rOE2Z;I9D8s{)5>lHklj;Fgj8#ST;R zV7Q9pEFD+JKZMYJSP;1{*wA4p&3B~XNFNfVhTP1p`Y2e`65^E0F5C;bbFYIhZ0C~; zBKKi*gfO>n+RG>J^a;6BNoMBMVmrpefP9E8!ASSpeN}WaCmd^@!_Dj``Ey&nGx)}3T-*ul{avpqf$+mw@@XjUcpUl0{|ZOMAA}>qmE-Xw40%kOI?C;>uw2eKBh`)7aI!kV*6d;Np`N#To>(-$h%j==xo%7qy@4;X9 z);EEXri8}~O_>lZTe$e5!Nt`E7n5mRoa|;U1P=pYUwao4rsa?SOZ4d!&=4)Axt#0U z>-jUAKhrjH@wFEI2p6Zl&&7?c{JD)k)86Ldx_x@bpJ}h~kC@rrqlSIKtcJYDGja8m zddELPiwxPLU;d>zJ$uoWjXcNVSlJli@Lk>4z}rxKt+0CBeLl7$*H%vfkC{>(aP`6N z;IU>d`Gjiy+1#A!U59lui9hB|7`&b~i9eP4ssx@n?F#->HZ(Ochq#=x(_quF@jALn zwMKQEuCl>IzA)SQ0yB9Ytvw^XUO0q`IQ3RAffa+XoOA$qS>|R4m(kqQdF;@v3?k~- zsw7L|OHq^-<76mjBkjRp)MNknd6T$Wrrt_ZjHhfiJa10cCceZScIM7x0uMG*pOIv! zIP_!fH|R%vMe>`xgG7}tv-TIJJJ>2h2@;lXk*-}gmU{6zdY4!F&)BTY#!GRp8bhdA zEIr43hH68Mq$D|%iWOC}L@NffOY^Nhp{*c!09F1 zPk={qsKUVCvqC7+ZBuCSzRKij+iKIzZiq7A$G>jYU}gq-G;Nzr#&GrPHS)S*FuA(| za3wvDPg0Sc$4MXiNLd5D${B7(YCNRp-Dm0kGu+GIfm`L_G>RJd%=`B=vIBvjGkHs3 z*!-`0Uk=ij2T#_W^SZk84^B60&hL_(vU8TkF=j6{zPoRysK%dhZ`=s}#D%{5Ex+>h z%X^mB;1n@3>N;`PGr?8Z(C}Yq9B9x2-*CRao+3`2wo*lj<&2gBg!36ODEu`Nn)buf zkm|U9!Aac0Ove~?LsQF#$2^M17S3Fab;Eg3~;YdYRVcn*&1LHo;v}q#y?HDYAMNFIScg-}^}MPzJ=b^X91ncr zC;BVnE=2P%x|r5{z0M1B>%n=FI~tyWG2t0TgXt1EtD_y*vR)Wf&umGq17|c_$3ITT zTm)@NsV->~CA{ZuwwZ&0RP`_fq_RKIc+M8o%4yM+On`*QG^EyuHl^j28%{q3oQe7l zmj$-f+!MOc(!CH`^Za z#7tpR>UKUd0GFtU#5W7j+A={tP&+#pTeIC+oj^Q-UYrJDL?9%FlNKm;H=Ou726_y} zACyhfolgF<_LitSd?g?PEZ+JPGc8!Tv+EvsR)3w%)`3_+=^Ka1l@D#2f}wIc_W-?L zE!{uKvvoja%bg=?E&)9qbO(U4DH>?5c|O7}cp3U(Y-M(YFgXvUd{~Ck`Z^(b_*N^w z)orV^{wRE*?axl#65yos;dvoaK?T!soCq~y)z5}Ked!|WCRXV5Y}6t4D3c}s#@gQZ zW-#zdO)~W`+d*1rd-PCB_%sZak1|%e-Y2+;G`H`{Lf{9k)FS7k_zp&QDZtC*6sSRN z?#F+jN^I8?%o0vJ=;H^G=2gs0XKXd=rnl)!t~S!M)luR3NPVqJvHe?xIgIgFJGR`P z7WNq@hDx!xLKUASw+5OGv!S%mbf=keSFmTfl63?gPTu}8TX|YuQ!g6}9ZCl+6^OSo zXz_(dAT}Q^9c7J2i7b6EgIf&plwD0(h?c8*`_)JM0D)SwhbYW;5-9{TS9_iBUj^sG z9>`xqSTn*z>~d|6l^*+u%8(fa=?VIE}!5AYjl=H#=KkBwkhhu$+r3{CQ@;AVz) zsnqG%yn^yR2TCEzfd@j)v=^Q4?t`)D!C5Nu8;Z;bRF_T&;IC8mQW4(Tus@>(sf#c{-AP-$o*4Vxj+;5=V)0wZH+THxQ{1V3+3W# z)tIlREqcNVy)_&-QuFIjz{ak2YM-Jr>?YUq6RuiIjE+;w+{{yy1tuRn$$3G`r%XK7 zut%eNi(|Z?KSFInNr`a`?iUQKpZ84+C$Yvp`dF3N&&(F1`PO`6qBN*ZeQRp!s$lE9 z5t#IeD>0O>PmB5*1r(CZy3zF+y39Su-^#(juyPkygU`@*LS>L>G9+v16ZX+v#T!|u zVX#dyC*oUM8aV7My%}kzb1#}c%~4^vYMUnbQSPJe)dZ`DSX5UD%MiTPEWV`e@?qt9 zr^r|t}7WoiK$tl_e4zjx{e^F%uXB2Yy#dOL(jT*r-5)D>&U9tU6! zZz{-7Zkvv6Fp+icjYetUiF6HyY72$HTz$<*?dLPY&aEA(=U{0T3>TtGUFGIph(89H zCx!&(PFtnjvoJQHHjS7_K$JJ5ChSRAtbhhIYSvEp{(OVCkg>Q=Y5bKkcYX&{o)47= zH@%ORBE|%@5pm&N66-1dxp)(Maxk|0jhq!zfM*zfO3mY^-XOAFDY6wasAmAY{v59^ zBJ7vpkYTxm84u)4BQ=mOOj_Xwuu+|WH%vrSO)q4o5myuoLXjA0`H(iLX}8=mBdHaY zY|+4*X;64)`O>3YrSZq|qZW9JbOd`=vaF{N{5ppGJ~g*=o(_UF^u#v3=g9h96ZAQE;)-@i!9u#E@Ww2d;o2Z4pBn z+QpF0k?K;+7B|UQ!#)}kXPKov@fS_k*^?3F$hDr;i|1dwPBPerD?OG0zq{dK3 z4~w$=RU$;{m?&LDQ9T4=-|dkKj*a$`;G9$)+Xh6l4d^;AfedBmTvI z$+39sX)XCfZg3K0`*vQ?>{)96)-0zvqZAC}uzxFvO6FDaZQ}DB=d9bn6R)ytF57aJ zd3Uf97}8UwnY1O~{;$wn4$WZ+Q1^OR0=n_p`yMvO=?B&?-3xlg_xAPDxZ0E7+hZ*& zQFwQ+0(W@@W_ks5P|~YW<4xVnz15?=r`kg!w}8}hYY)`;=4gCGU2tk|WmE#rL`ulG zIDucYPzU!g*ZBtxsx*w+e`jvZX;L0!{DN_3JBck+-K%dG*uH_yIQ}J9;08wpT&gOy zaXudi@=QV(kR7v>hI{ALt+_jgL|b?Tup4HUL$;scs$nXvcBxLs7?-4ww)CNafLZ~W zY3r7wV)CHT`ToX%(r(xAmtDN!EEhzEERJ%GR7~!zV84&<0C&4r;f-~K|IYqSZ7CSO zELwF_fqywr(?s+dUnztsxszX3w}*ozthOb)`g(g2e*p>8A@Divs=ujft zE?|ezR}Er^;T5ozP~s~Z8A7SnAYLd@C>zL8=8{s@`Vn_tfpTl)m9kvaDyNW% zGAol}w3|t8^_Fa{Hzv55MIpQ=_t1UGMD&5XkeT*ykL07D{^wogvX=FhESI~X&tzbF zrSQl|)kk*yVUGgZWl2?o*h@LXkV5Dxycu;M^|f5V!pe61IHNl_KWSh^p^D~4sydt> z)koTQ5%J3`M$T){YL?~Cr5%f;ZwiVLYIbw1+5vmqVY;j>Al5?)U&v_l(MND~){0dCP;x zcpyg}E}!I5U&iYD1_=RWJxUd)xSkhfZqB80iUS=Mo0F1d?nHJ zNaqnwg(tfe+bQ;#@rBm97oSvHj5o@4ZKIwcqBoiwu^z3p#KB|^0Ki&sa*l;yr-W}P zF$RXw4wCR7djJEV1_a)PNQL)HN3H1=r*`RxqK099+8d<1AEkHd7AHcv2B^H;)6I`& zYL948hJGprN!ehtW7bG(OD_8BCaWr>YSmP>n3~;sAEdW~)+=J=H*Ms9UAowGe#H)Y8fa z^G5Tv(4k&mQ=yqvpZYbL4sB9D=z{uWR)QPU2N(b}$sRO|IjwJIM6oc0ubY;}1k@E-lK=f~gmV6Z!A&x|WG@@Ay5~+tx68dn}{)l@CJl$GEaU=Vu(JBSP zB)y#E4u6v$7KFJ?bl5Ns%C_(buRyaMBcoF0LDgVr)FbzB!yA2#{{wR{v4b5s4zI{) z^g_2Cs2}QbHje;ZWeHm@gG<=F-4P9}s(D?zzrM9)z8yIE{VlZ)^&l;u;FStZklJZn zf=e>oaHnO}&J$~cMXdYb``|FckxQ}-GEB4n0aEGv;@!epcke8`9Z!?n{w z09M-Bk$iK~M_AWAhMoGL+yB_9{UW_doo}9mM9r2h>x6o^%5Sy>@5!Vwb~SS;X(UJp zhp@?RW^>5Bk&Wze7NQ7}JR{z)Z)_Ee!63usB@?1mp4l#n+0L6Bq>0!hMEeGDO;_rZ znagCQS+bV~S-TCy4G~IO>-n7s2`4DzV^71~+nNJx$rvz&Yiy%|W8sc6UrQ+PYR#Wg zGdT32?**)5^xpt$QWi@!ZDXDe)Z(jv8_nz(wRzL~oDA#aCif*R4L!R|4m8U=56&4Z z19v!Zpyr);L+rI<6R@uaRy(!77FenpBLIZXcr%~+0Z);;o?e24&PY9{?JTPhjzsoK zEH?1SfHbWl2x#C#NPaoalArV12*umzF{=*Xc}s!+a(5hbdlR1AS|D3PUeGY@32sh5 z2?$&{;HJpWuy1|1Y9lgBy9G?>2CW5+bh8prUL0b*Gs5k!Qp!lLs2kk?lYUF5p?Ou} z&g~R5xXi~v+)TEfm&co9Zxe-pwNQK&_gGAQ4e$5is?x|YXtIRmXnr4N#6LO!Xbw8x zeV&=seZZ_<#m>v(M?CiZA&Z>ADA2r+y;yj*Bl{@J&rrawN5{fPjfKlUm9?f}+Hh1D zH1$nwHT)Eg9N?7XOuPr+LRTxJRof@K!}(V* zG~#?mvfw?@$Tuk(!k74@MX`h`lgqyeFM#R z7ZKi8V7MHMki04O($cii3e-OCL&}NgHk$_EmdFAf3n&b_^Ra-fglTG4ne->x!WYhe3= z|JUC8$46ORiT}^cM2Qe*lA3B-(N2}tq+(1cAgQ#@gh`lz2}FJ-GJ^=k=Po&vTyp^W1aJJ@?#m@3SrbPqMCt0J@DZLjVcmGkPh4)@xO=5(5u; z1JU2HW>XV|;I&q|?@z4R_&5I!i_;(T5Jw_<;7=uQUV{d-x;oAshxhCCmV0Pm1FamALx|~_DagFXa%C1b1UP0{AZ*LMDK}zhLJVYG_FT9 zgxs3=FR%?rjjI%l;{OugONXUR=4GB`_MfPa>jbx6BIGwfzRY3f63{xcsko`MKe2J; z*4h1UZ9JDl4%rv7%2w_8`bhu5-m4@DvnT7&6d6Z&5Vahu)U>(w4E$q@n1O%wF*%RD%xQw zUu{PRoF0l*=c|d8924b(eRtt9cQEMqQw=-5`VK+A(pU2s%**d#=KL)Eb+0n1eUTcA z5b=sB7``cG=qUaJ>c%*$b9_^P#ZT}D3MMo5aP$DS?P{h5=U^Cw$z;TN7!893?)!S5 zyqMFPB7MQ8Wz(jM`dLaLfqjtpIQ%B-CS-%DTbRt2pBxiN)lTd$*^TuVaORI5+joew zwFP$~l$nq11Az!;Bfa!+Ul&`Of9Rvs6N_`5;|ZFLQyR`DXvorRzuoN7WV1KX`O;XV z+Z(J#(d49@E)wxJlbvg-b>fd%aE4ZO9u+ygKTvfz@(o1W>AHD~`M3#%teC`K(WLkd zv@Ru&gie{QVT7S7)Q?Wr8qaeyTT#)WpQUlkz}86++K>pnJ4mJckUiUFOr`_eio!T5 zNbhCBG5N@A(R*ZFyg#O6TyRw_3LJ-m-gN4BgSvgp+4tnr(5DZ5O6!gGcd=IDpH+H* zpLERAqN^jiBj;1j>Cni3LnDW9<&~4hN3KKAtR6Ayytr{aDN_D1jvr@{WTo=oCF-da zy2xF!E>AWWjMT`%xl6>@(WOnjjv+jre>Nr)hoge#sn^zc9k!vyXNB0z4M7i>BOH}1J4J{c@U zE>^DGObN96b`VW#fOnIDkb{Wh$*ebJ`ft;gP2iTE7(qeMZiBmy<5l|3C(B-s?!j%a zY=881PoMC;^6zco21a3&FCB?8t1W&+Mk)^HE%KOr3NSVt z&AaKV;-0Ns1e5OBvegQz=;J6DCWU*ja!|nVJ`P|A>=gz5er6dz=Tr(A&2gebsP##; zr7Ep3b>SK>oQntGJ@q_@b9Q0Px4FR2+ph)gOtq33hvkWD0&f< zj2@FbsQDtq+i^m_jN~At_i0GRm-0(~$I<(Lf=x$p+w)_%ZcALYeED+icY4?xDBByG zd$YgnFM;T@%D1@WE!Rxyol)`LQyq7k^QFn|zf+qU+l7uNVS3j>p6 z1-)>pQu~@MHScJ*yvVs?iw}=YV)b-Vp{J;Ql7O`Tc)$`$s|e#n@*k8Va1NL>8H@G!# znxZ`=y~Rey2~AM0^4lvNd+?!jo4r0f@?$==F3~#nZ@gqgV9TFqKH5OU;9ZD{SBSUQ z+El(I45NY#6OsJ)UxH$D4TtEiA55=?r*AnpNsB1{JIP$VQtw|*NbsDr2_$Zn(>`uls!)m% zOMjr?9bPj1ELCc=?UX2e!q!@G+LY6RrQvE!bt>7giMM1(78%u`%70%iRo1mJ-7}ra zq@wBWx#0_@dpr|fitp{kVMMu3abc7ELHBa-(se)DHGxm-9(^0Cr zlJlLxifE);Reh*>-?vVs)<}0bOImiIZaq^LN>1YmQ5=eG#7Glik8P||6yg%>kqGcN zrFzJ?S81_Y6JfrCSIJP&_Ke_o4;Ci!oGd!Z>Ia(-r6Z-Pb3!qnQmOe9-@NE?t=F84 zBC^Z#)$h2)@c2#sl?&(;l1a_yh>^WQc_}DYA~b#L(3wejCF{#|4$RcA@rjjf`zcEF zQ`YsPk4HzycpnrJ^qt>9xLL7)2X(od@Jt5SdVFz)p<6Tj7E>*S+e;h2P@-jB)Rb?Tq%sDn$2H^e^_T(#;?<$ojc&YaT03 z$3u=|94mt7@bu3ZmcuD&M zP9^!+>b)t#5vuJUQpB^>^7I{rBLX5<>B$PQYV>^ynIYu!JTqC5^h46m7!eWsoXf@t zbFL6oVC(t8rUT*`bL4>fPTW*=5D`Y9{ekGKLKirh9N70NLoCX{izr(o0u&;`5X)T& z=c9$oM#O8hRGz&&FO1#zIPRIozmIKT($6o;RJrf?vxL1An zEpJF7;L$iHrVON!+zmUpYp1f%smfpt^eIN|R!Cwu?!A#y6hYF7m~~#gX_Vsm5 zaDeT7pNGyxc|4e|j~C+RqWqU0^%T_`|D`Idthg;RrE6C;R+e3K{32`f+-aP%a2k0A zx6;X=a}9Gb+%#FY*o?0bHnR%sn0pq)@=lYt-a5>}hd6`g9^6Ua3iI8^zVFiyNqVIl zaOYKvyE3<+8L!@ib6nm`l(5sGSWf-h6=q?GBf9dL*VeK)icz)H;n{LAx6&?{UAu-H zRQ773)+fN|DFz>uUhjc1;bK)&feCj0V6-Z_^`fa~V zEg{HW1EI{IvYa1Pc+#?rIWPv~63!je975i$b+Pr#aaQp))GIJW7N{4-KNBeO2TjHn zW3hQcLM2Nx_JE?Jq`WaM0c+`iI^H%X(3E zD;Se1^2(>ASKb?(eT`V~tgKOUpzV`z=Z~#UFwODw&E`J(WaZGlm&K4VAnIf>Gr>X@ zj5L|;XXci4*p>~UPbqJ=%`Z429}`1eF-}EFBo#a^{ZcSQ{9TkKzJf)0Zv;30iN%hG zgXd%B4?7OWucn&}+v8N==^I5Z3vORgD+`+I87}IgZ!l;Vima!VXMO4-6`rq<$5cvv z^+?3N>P|0=<`ulfX08^o5NjU?ji&cY^`bdljmuL$NIZfo6U@3O)_yH(&&Z2VY(CN9 zY4{Vq5ca%}Gf()0Fo|eM;3P3m-0S)30&wN&5AeTP>c(qvHTQb@E>x9YCFDlVb)1u= z{flD7oWn8ou;Hh&Bd}BuYj@vnnx*A%IzI`AQrvxd=gdtHhO71mV~dns(C_&sY!!#Q zhHCP6!J|h!eOnkZ8GbxlzQj$9_>h;5Rt{k*M`HXzPZ)fZBHc-+&g53DDD0R(`a=`vxV9g4|xUHSYd+d75Y_F^Js4!J^RK76g>Wlz8MMG>u>5u~Ed z@kX8F&7cDu#P2pbk6J`Jjy+fUw?MYwG>rset(-7Bu2@I}E@aC=9%}h=NXVEWo>P3D zls>PVg=QdMrjovy!yHy|5^v657+dwMlI0aaz8MCq+>^;bM-7Paw$N4*e6|!0+TC3* z{2`}im3VGF&1eU{kevO6e?vI>EQ_&k1|8@P*veM49_f=wapmsQY)W-M^1d z?B5a9zt89D-vjT_zqDF&!%*Z@A#F?n+9g)=!-MF;p8osz_iuicF$H$4EBmwYF+|j< zbIsJK*8eq8De|$QYe{;XRRkH$;dDLESA+mAOQgS$V69s}8;BN6L(Mp*G(+u6D%kd7 z(S^4Q1F>~7z?RBVfxs*1S49+aL^S84FRK0(6;;mi-@XrhRk5cO#TFK|pFlJac6CgJ z5Yt7fmYXg<(;`xH{!xzb3zQ8jE#+^>CKOw$+=U|kn&<2ve=>tkCjJ21LkqHv^Dz zP#YE|X9R?jR^}Z5qc_#*m8{K-xkN;G7tb|XkJ1m=K$At^foZh9vxbjR2?dZHO-0|K znOpOwA(rQO`gX`E*ix9Z1`nUN>S9-Oe1Hh$ytAd5;y7AyK6;S@0$7FW5Sw~0-`G9N zLc;Dnbed5&f}#a|n~LlCg{}WQN15n9_uoVX0<$>$yx{DR98>zOdyv#h0m7tGf|@I< z%82Pxxs?{OJegF0l;K8gkUCNS30IAZ{zFqeecd9N9q}Cck5n+J|M;XOY!49amAev= z$%QCC@oQi~A)GHC*1Q*N5;IDn%+Wd(2vIB}FY_~dVg`zQjH~u1-bGV^x8`W+Ehr!VhI{u>>7*91`CPIe=YwC-5-HReI@DHdoO4Rz(*u53llQ|Dp!k8)g!&n zMxSJJB5S3POuZUTA!sHcw6<93M|ndC1bo7aoN<|r*>#nALX54<3MLy#yV57t#FOKn zhtZSmC!YFvY6Y(X2lDj{jzM^9SLr!$hL80K5y#gP zOY%dY3Oe%MfI4ms8&#%4r^Nr8lp)7cELJI|>i>HN^7t1>s@F;0mT?^)Kq}9iC~w&I zF9JoyY(X2M4GP;U>eWJW{m~FM*yrMhR51u&cwOnKL?4IIb##x!W_oi}_PYHc9uXI4 zr~z6e@+LS@#9Hq7UtpXub&?HX)Jc)Zd)4RS3`PF}+>7*rc0es?j|QVpYQ2he5_%I| z%bve;-U?hPrtkk2Q~U|*+0RSHJ0?gegO&?45{KjEURBo}+O_$CatNn$D zqTVGLCbYjJ2eHDH>6cKel#t#2XN%;O*B$EW#?yUH)Ns#J5I$M2$EF=A7Q~r-hubaklh%|SjrqAz_ z5k%?#HThXJo|<^D|Ddufg4_TdTfz?K0~tBqO+SyVA-hoY8RbCPkH0bA9iOK|Ga}wz zsylrqaZN;3u%~Ycg>KbuZ?`Mejp0clc)NoZ;f{kriH#{eoZ~5yr7(b}Zmd`hLkt8s zoBx=~disCBzu$46_|f$ZW6WaIxmL!n!n&qc>tfS>FB`fR#|jRIVqZL}w^U*cA<}9l zlY5xKANrWm>(p}n+jWjdS-R%SI(_m*GbuGBQ^N-^3O>W3wu)tRe<7bZFo)q3@yBd< zh4>&9RkH^5PSviPpBLlLk0d#3DrkHz{#af)^p9%K_ab^v9q5;QMbqMQPN19UVU7FP ztd-}1?brWfA_k>8O0Nz!aaOHNB>J92%L>Gsd<8Yg%4kwaIDD@YI-@k9|JK68I_C+k30h^?qds=&>r7l zXEoQw!LJHaYS-Z0y{xGn`b4Te)ZSnA82-~?$M0p0?N+fvLmWwuhi3#8ET^v&BQ7*x z{9n-1mAt_gp!MUYL6O>c;8OMD+)|OMkiYns3lI8ZSEAc$k9~En`dl?FQrQ%SV~t1s zN@#~;t@*)Nt9;AbjJu0XZ_LAZ^Lsgi%g-4Imjt5EER3Nwi9Q}E+t0xV$YC~^=?S3O zk1mInu^)Y0_M>y~RUO}9cl@3mp7<5X&TNJ-lsf7O)5T z48BdnFeD#q@%;EX_QW5SWQB`k#WO?Er%3%o=*Uw%Juc2SkXW$k$;GkhN5oS{+-U;P zx#NiPSbhE z^tAa$4}B-qpEc2gkpEw3%7u1Qx+zSL4f&#wHc8n~xj2d-pXMr4m6k}tB%b~w{BM@S z5~_%)7#$tuOf7f$f>H(Ngdu=tK3c~tQ>{}RnwlyfT?4|$RR0WTeQrB~av@~}9zPl# ziLxa?`3@Zf2WKF%9?7$r1cwP2Uydo_R@1@mhpScM3Cs++)XQE8e;_GN494rQd z?Mrdc3pMfCpry(}qW#L{V5uEA_nYAgVd8il=G}kjEK@&BWm@t*A?Gnvz2>>~ToD}f zQr=$E%})ufVqRG35EL_CeNcq?AKnsS{$w!vj5<`(mg5lZpBKi$&yHbJzyNSIZuYy_ z9i+drs=*Ys@^w*UCL~nKGg=Fdmh24zh{WQm0-1$r8D-S$PN>{VhA4)3_pljW%H=R|JH7YLGHf^Srh#Bk+*b1SXhp)teN5eaRwQG*?l!t&(%cVsPQc3RE&L|?Yp5gy{aQ8vAzg(Vw2?X^~hPl z9Vj!bBZwtlZ1Aj&gr}()7Xi$cFPwQHXp_3bjuK5g-4$z|q2Wb&hvWZ(xmIibSHqJO z5+`rc5IlWLsCMxfIyWlc!--Vi{!7LC6(4`#`?*~u9uww>Pe+!&Ooi^EJ>e_ zi_S$oyNwhl`g~-Z53H8wO=;JCGOe^Ta+H>;D)n2SQsDpbgKSkpV+C<(3A8hSDXk>E zZ9mA7fq0$kaZWjgbd#Sv8pn_#9vQQ9I);ePyI|)Oa*01Ja}qsnOAZ;;qA53crSZD= zw6amPmdzIhFR>E-8+-bJk$WR?$+VlkZE(J#zsW19q=>4y0 zLllA>iW z>qIqbZHW;Q1>X1uu+vXoikZ7aZq`J{_l@aYv9eY&02(>#ELtRr-e&$G?@~nX_V2L* zFZWWRpv*s4$UZ+W9|RCY)H4XZ#zX@R0UXA{B@E3q9OMCSh(^HpAicVVJk)UX=Q_vp z;j%x;fGFa;09~kjm^tW^0XVRj@AE~b0ADSCMFshsXvy5~reE{4azQ>=xtx)86~28% zm*dUqjNHY1FjjpW6IYPcwh~dQgH%PelB zjU5oRX5+0zwQ>ZR8jiM>a9^&c05~>zo6wv^fy@#Vr*0eW@ z@=nomMdX_~r)tOPa!%E;K-Hhw$FY&g#@L?krAQJreJCZujYJd7BQoJW_1WkE>u=JF z7t2f~wNiA}_7a)5UJ5?(yr=8vheIgyYB#&|UWMnY!?*%@`tRYNo-fAO-v8`r>b^v| zCB@a`LB>C*fwNgqcOlI==m~H7f2Bqe#}Jt1w992Dv(S!SGIt**M_dvt+sA;<5~R35 zG1Co3*+FL;%)M$6Mx?Qjh*ZQU<~Y#%xYW?|)sHCpEZ|@0(Hq=4bDCl6JjEX2SSRZM z5sR5(flIA}pxPey(^=c^fnCfzsz8(%O|Gmt}P`kpD0nL&YIP7Og+WjbANVKgSN(w?rvQTeuc|i0!rf&lMGtf>yobDVmFN zDTfpdLqD==tro2tH1((*OU#Sz!R2BS`ryif5zIQuF`-D2JG@XNEx6TB0$KNiQSSHj zf6*YJB3w3inwo7mupPq(Vl^)f@cl}TFxrDOj?2bVMGbX~VcI?9d_cPGiae(Bn3OQm zp-^d}4!2^uv=m!XDCW=S^g8KbpDoUUd-0J{BZXIn9w>>ExbSHb3KZEFR6MOb8)8${ zG)QuTHC7(gYcV`kq~?dhK2t>T#jB?idq4v_MA)CC+%=ghJSf6JHbSgsSxITlW1%Vx zFv}-vhAudOTN8dK(KjWsh>dm8as1{ZwTdyKukU-Az8w}&#iB2m&yOzwD+=9tuz@h&ZtdHXe##etuh942xA-)15X#8?+n;JOAg|!grdlXkW zK%!py+@<&gl&8*l6Sj$IhLBh|8-N>eE8}cEK8Gf-Qo2<8j@av-^;-T3eF=F@VnE|- zdiY?yz@2b;urBsRPS~qGF1}YZ0!J*yPX?krm2Vv?Q7e39h^yn_s^>j@zgFCaJf$ft zD=TheeM`8l6wfQZak?mhtD1HVxi?e=Lcg`ECjUXU;f%9p$*8E9Z3j30C?Zs^{m}J&CfRSFmvh z^2wN84Dt0Z6>$ZP1}+xIs#`zDP%Pa*Q>b~UiDOK}U*w4GFEYkE{6)r9YcmI~|PTDo>{ywPtTcqoVb{Q#{CTEMW(5xLs=m-Va>YZ%DSfe92HMoK&T#7(EuMWgFt_nTsEwy%o= zm?)h}PoZsgKkHG{IDb7thZZ1es~ASbmdeMJ>#CmD!{~!pwU`4a&aU7_`+hx#0`CV2Q02}ySKN#3VN|&n%P{&}y7$+r6n{J3exHF$&rNp|0F}{pK;6(k$#8}&a@>tinV@*Mh?gq$w@EF`wy;o=EXzO2@MCK-JO!#o zZvKw)R;Xb^UD=U9^cYIw=_rYO#j%ZVPOyomirY(%`aHMa$GWuV_IrH!k8zqEtwENS z^35j}#kSnVqb^{aEKs@gIaq?Fv8zkKBO1N2?@6scD&#ctG$`o-6f(A<%@h}z!XRfS z<45?8a(oEz6}7%eij-iD3dTywyjW@U%ktsV;t`>F8X_wF=AtnFTv>} z%6?jB$-%ZOALP@WH#W-7wt3Na!m+FJZ68}bKT`HSFf)@CE@gn`5QR*&=_!R#{IaVa z*M4HfDB+?q$%%WSI1Nb(QRu|RzPex3e$*#vRB@<#YXZvc4p{hr(CFTT+LD-HNk7SHW&k zdRTM((!uz3tQks|S0E@kwPUq%h~smjB7X{m2^4L_(1^3 zw<-#e0S{$8zu|~XXz@Ea3KKz~D_P|!DvUp;rnv~?EERYfeNI>45?%O2XB)G=@ZRNq zgIvVVW+bEBzZJcaVx^(7ElI}AzVGMBV2*Pb&S)}pFf1bIV#O}xHthrZiXqt&9Mt_)dQqMMS(*fF4yUN*=0+G*9UR zcKg(^0P6f(**LN$z&CJLc>0RzDO8se+V-wJ)n#O5z*Gg!#)n7>jC_u-Hh{>-!qFi` zISdBiE8b4&~KhEosj8puOYGwRyRgr!Apitqn!8r3te9`a*L;j@IBRgMSB7)EOp{4k;Oo_u}v)u?~UE*9V z3#8R)GC??J_fN&Zi3?@#0nC`PY1K?vQD#P`KfSucD()w68**L-=3oW-N% zP6)o-mw9f?oJ>5MZaqigIN83=Bu3T5O?4|;N(z(dc+A$Hnjb}jusL5-teO>WFC_c; z8GkgCWSR-#%BNKx@!Tp$ug0AWc}hlbO4=)O7-^E|Zj~KO@dLp0O53%tv%cGo_%`xl ztEX}Zm*bXTlM~U>h#x^@8N4H3rTb_-`YMMn$U!Igv6_S6lm~&z2DbsFpKwsaGW53# zhhO(J414C^gXN5>?&39v>e}B&Qz`CUH&8jm&!nUMnng33atPkzf= zR(N{`F(kJZz-p{u>6t9)Hmg;iR)V!D6&h0`UR zRkO5mR{2F`Wmc#o($d}4+1?mw>+JA$b+&axKIct~TM?32OWP!$jl8+MrEPs{q$e3? zrq1bveAkt3Ec1TeYt?LwbT{V6pQN+P=agAXT6)@=dmG!6nT9T+rlA>SR!w(zXScU8 zqATXL%DthQB}+;}D(lhlrM8);jar6cxuX@+T5OEV8%%iGh^)Y;M8Q*PC@Z0PL1 z-rLyT-r1yE-6EyntEsP0dwa|J#&%M5^+vqSZ5vuTdcck3X<+Nx+FPc3+uJ%?yp`n^ zL%q7}K9Y4Jx$I{<)X;I$Z~968!`5=^y3X#aZHPZrvFkc}+nc>D8=G2a#RgsP_O=ae zd>ax{k3?EFbVa<8PH&*b9}X{`=U-Oi?d>oPBgJ{2>cMT#AJJ8vJ+so=xy~z<_cph* z_jEOO_p~U=&?VdPX3U;5>pdf?=;N0lO1KW+tW%Ggc8#0o@kAz_T0R}Go}Kn`oq&f; z3Y`42^Rq)c{`e)BOsw>uSntw*ScI(fA6v$)^dELLEBz;|lm25J#Y+ESC$iFi*!-;Y zA8RdE`mdPh^dClJEB$vm&*?uNGpcgqBDl9)QKcP`c z_X&P<+Rbv$!jko6c_5s{&&gnrK&#t)^NQ<=PARnh;a5Le@!C^|Z;sZT{n*paopW_K zI5%f9wPw&f z_J)(>U4{<3{2H#FN9)$sUvj~`sfV7Q{qalQ{lROG$aA$-Z!NY0^J|vX&amcL%eoso zdb&D$TC7E#USwPHq2q$y4mfjpS655774E!_|G?rUbu*S&%LTqfv-`Tn?q;1ytqSTtt17-kJuO?ZRN5-IOI4pL zCWAA}>TFFUzQOEnO`g%`F{GZ7n?)u5EAZfh56a zU7c42m#F}%v;xbPC?J6VK?_kVtJHg*_cNdIF7EKQbVL{+kgMlS_xh&;MpQO#XkkS0 zcJyvoOTdfJ40+Sqh?t!&q|S9-BO`Iu7e_PzUVVwiA%BQ6GjcTGE%7={@(efn6U7)Bo`J(gHQ z=$pxV!ok{Oi6KJo%43Of3Hg4K4tVOp`RU3tUw4Ca?Zma2nTi@Pjn%K2YyF-gs<=A;|USEYfecdo+2D2JWAMAkVyC- z39mbmXeI3WNFwnN;oww4gz(T=iNsWd@0zm{i3-9IFX;%aPbU&P5yBOrL}C>Gi~+(o z2zQ1PiB)Hk-=&Gf5Mjj?I8OOgP%f*RekVyq6H- z=(>q`pCpv8W}icSwj>f8&*eSgHo~1>L6Ii(MaiFV$ zXeJyVOe6;7`KO6Q$){+~&k~9060+^YM_B*ML}D4C_xH4mu;L)~BHW2#YVN0bkH=>{ z;Sk{tLb+tjk;`$z63el%&~awLr2GMxUEnm?IsmO*C=mja6w^_>HIv`qo9`y%Yb=(# zu-09&z%%8#{7u#+AHVoBpPfcab^29=D@bqaHUhtkUxZ)R+wUf-&)}xoU3jZA>@L~v zTH^M`@~YjX+fMSkE4G~MchA{8X})`)z;*vA?i~ew_s)W#`%Zp?{O&FYxrYdc`HgUY zfZu4r3ilY{c)>N2YUh;6?m6V-cb8VXz18j#N~(6}`=?wv`F*mhCcA2~tAQp34|1~0 z&Li(86v_hb!bW$#H51reen&mW5|0aJR68hTyNlAYv}32k8F%05aMrj79e(%Sj#~GS z<8n99Hi3qK)&dOz^}C0;A0a&8nCBklhp)bS+_8$-t}C5HUq$SCVpkKpn%I6~&m*>< z*mWj$y~MuHMeL<%c`r11(?k_p@~*b?ZgNOfu1<>{c(1D5>&$^**Mp86Z?OJ=st9zm z^ApDsCkg$$AKvO+YbCe92^|@nB6$swM>7_*|JS^xlUIQYd4BG(#9g8o`rUJjvypG#UPw&wGhKm-u&^Mlj%T3$8=mAQ>&?I5qG zo<63X6W^Og7Qh9r&Dlv#y2`o*J{=>!Fyq+mD*>qdYI5-^xSZ_z_@t~PTr@zdP5 zOkV09n7qinWAc3W&dJUdlHj%i!0mtoHni@hi<_7^4gm-C3- zMeJJgMv_eal0YM;0$l{O4d_*-ddQ;5jq>)z$-G4ZQLV=no;JVz;37s*TEnY$W~ zC%z<&=$0`nXPup|Pd-6dEu^kc=)}Qj;S}eaCqkT>@J($Y~yWin#ggu0IIh>-H~5(tJ(kI2&+pa=1pb z^N`|isgLX&-4QvSct^_SDuJ(j!1~blUKJVmetb3La(&m~9(L8cM;Ij!Q0r0GeD@f? zaaRZMCBUyFgfU!K6Ee2DoW0yI(76^9h5)ph2(I6{xO2_}G@rcYo4gi~*E(KETFFE5 zay=taugnrtVn8>pZbB)<`2%j20_Y-CNw1WoUj)K%Oq5Z=F;|#ES|s}AS!o803BFdL z1F!hX@r2j`bcEc#K-SvVPFawRp`|VZ)MeTa z^*kYKT~Gv4x}nqcip#yjNny@K?mPJn!j^YC1MVTGbD?{{>AWLr`GF~}T00#wmiU9P zkxti2GV1YP{HDT(B|pUvpuolps_u4Is;|=P!ub1u(|wDxh4dhR{B}C8Anyg_eKT+n zLpeK~wWhAaX-{Lu-RB*ZS=IkDQG-+;_X2S3&V8r~F3XfCH{e z;f4_05QLCuD>)Rqh$oD}NTrxnm_|6WOWux1E-TYA5x#BY?Rt6pn@PNFnDBPBd27jr zkh|!IIR}p?&SH-BzU>*vb6MHjGk=Qf;geyNCV0RPt5m}(OWb$oF^=S|hd-PN^AeP* zmkZ3xZs5yFL`Nui0C<>0t4ZW~9D>T*$lC_PeT?vVm-4nl-kv3I8FrIt<*lS`ME6`oY^Gg2evfyfyxS@rt7OLfq#RGpmsCHxKAvTi5dkhk?JML{ z`tI?>cZAQC{S7bhn%kevh#&Pob@K{6(U!fc)g6I zt!XSN!UOVwLrA(pGDg>%4pSJoNDIg7Rw1N!#*buI)k+GS&=}-#4cu61Q@BrwbpU1yFTPzQSDw6aJTy1 zU6;D+a|!yM|L=*F-tj%!@jV(ia%v)R{z*J!8#5Os$AkdGkL%3re2?y)N3W`(i6N4C z@1Ucb_;pzuj%xNqT4cny15VBndBGI1hlLsFS73WO|6IGCIr&D_^C1Yu!AJ~y+{tf{ z8r@CphWHKh8{wyC>1!x>DRFB|T(K6sS6pT$$$Z}{?n?4?Zp+$yL9 z_12ONtoDJbCvn5XMY_?XI~@$YC*-@{H_~QRkEtaR(;_mcXykA!d`h))q zUFDi8x2ZoA%ckbv7QpA&u<+C%Za>`93PRU?_vV?}TLssnOlA zY$lemyz+j)v5>f^IF1EbupCC3Euh8{SFnsKMLwzCTa+c=rnG!fyR!D)8j~-osLB^J z3t=kmnzVeE8;L4ZVb?cTzKcx0Ytr%+YOBf8Hd|7sQ`==}b;w1Tf(NPZUqi(oG~bOT z-w#^f56T_yh2N&X0>5^@H5>dY9cCMfaIid)SkCY%S2Mqzz`h3Tq@)dF!kC(xgUOic zT$pP#b7ofx0_etTC@248*mEmcpGoSx*>r5PCNb)8ot=GNUOmNm7@Ze`2EU`2@i#e{ z!l2{HM&EYISTPHiDQo~)^_Wy!=F1%K5EeF+$kcoi3ma*$+CMKFRm(>`3%a zX(gE`#x*39+4yRb$*fvb-{q*j7;ngCM9p0lzBjVYw(9frYf?AOX^#~-;p&pL2~if9 zbSVk680eR>cD5|rSU!GFQAYkH;x?-Bt!!nRT`1JfuTOTDu#$tRtY*smLJTxWrSIe+-b^4w>K^j-CgOtN_SuE-n7N(%Fo_4 zOx|M7#TJ^tD@48g-MK|NZ;SMv{0(h!u6GYh!V!6U zK>kMMZ)^*lI=%%f1(}gK#WYJ^P=SCGmR|hxP4!i@P>gt9s-G z)*sVc$Wa<`r~FZmRGTolZ*j_8G>^60P4)0)rkyw>^CV>_ou4*OI^dwqqYOs&!r6$! zIgphO{q#6P-j&3@LJig)8Wc<0PO+VWnwiFUS-M%5UUzV!mP{5 zLW54e(1;j$5#og(?h{*(&9wH6HU#(4eW0C6$^v1ST$h-d%W$Y|xOtqIFt8limxb0+ z_5~yR$SIz+xfs2FVX;8Rl|_b>Z6us^&2`Y}Iycv%J;{Uo3eT~upWc{A z+=J~%=cnjh*^Je=qiA8F(82=7bLY2m5QFG$tH^5(zAV#{bTxr@l>J%B6RtW1Hx1f|uQtW8o`viNU474gi}zfIm+f>=j@of1gOaWMI->>sGH*0%Y43V|U7a>eu8-IXKgPl4pFU3b{97&DY0e6>keb%hd0Hj}ckk?%N zd)kt=d&QHfe#oqs%at8P)uK-bKE}vz)kq@o9q#1{@Ou~7QD7|ssFgL%P;z}k)mQa( zP_IS#I9l|20p~VhZy(}10Q1GLkxU~fe$h8AqGCgz=s(4 z{}l!bnX}0?!W>X8GbKJD+~~}F|MdyaKX&Q&GUZj5R|mKnsq4;9=m;!*sH;Mp;JIX4 zE0>rY<-%02t~utt*hA#9-@kc0(W#zIdG=g$6u%3(#B?iHg?TS-MRG08)1l0R7m|WFm z$73hGY9IZeKzJRh=N$&I>;qHJraIQRd7f$Bb2^54Z@0r_|34P^OutObaJE-NYE5{V z3D=qMS`%(D;nz)ghY5df!aXM3Z^A#C@GTRb{7Fk)r=gHAg`aATXX!VW>>NKgTRtAkmXGOgU1C-9o`@h9 zJIY7T%Lf05HRm(g;HO!(yv@wN*s|qpCj6sTHa>T;^W2t;neorCEJJUZ@Dh$x$W|YF z6iCGu8qKp_OQazBPQ<7aym`$yrS=K}6FKYvKNSW)_BbKYvgLE3$!E>E+@xKV+)Mrg z6W{>@x5q_0$rao5hDSAA?LFi64g>cJqPWx^Gs0a4J}`+JF4?av*8u|` zEYNUu^gHmwJZ8h&QQ$%+o7Cb1dV$IXJpp;-VDv6F^l6W$MG9VG%`tF$Tt3UdD<;6p zOg<$O@|kJk`zFNqnfQeh;x9DuODDv?T)_)1pQ*pk)L(pgv$eM)2Rs*F^s4+nVr^TL z$)~yKP>Ro1?q>3llP)I8CD9WdS>(oDD*kCF@XN0ad?H`S9%BdE+C;e&q=TGtf`?bi zPhC$C|0BW|ZcQg@zaOvv0|n75TARVMo#JKU7dcO?|1p)19V-=z_?7%Co+AR6S~nsr zH}HXf({OvOaF&9rs2P8koA|y;9bftV6QdzV{GJ@}0h7;8qi5TC@y;CacboV=IRljI zC5s%$KgvvR#{^4VFV^RfNW9Wa_~5u13Or{HdD z-fqi3;0$8@480A zmERfg+YG$$HjOZ~4-oi2N_(9rj^p1p@yFHq_4+IrqFX;uaJkF89y0O0Khfpd>%x!P z@bBt!)m}c59?X%?JHQ1$^%L;(F$hEYtMJRFT{^HnY2e@nEnwtZD zWe)gPbHM*e!5M!8x?Hsng8aXmBmS>Ud~ctQuY9_Qe{YWX>KqHH@Pw-Xx-Cl6uRxc& z&Q$OcYsCb-U1aFodP5gyC!Al(-{hm9{YV=!FNm@K9?i@GT`TAsb`m+&z(9S zwQrPo8*}7yYYw>VgB5xn{CABvMCPsEqK zvy#8>X$`mi2wqV6oRQQ6iK?!{D!%=c3a2nmDZW#m0I@8!?~~W30WWf%VcGLFJB3%p zx1Uns7fe1CM$WgGSBngMWQ(q+@=4^~Wj6e$8gBcHtTOQWJ2YJRH4(pA!Bgegcbjs+ z<>Y>mGixUB%TIH}KcL`lYv4I3K=!<(K=lpwRZ;in1OFno7F5!?RN$~o+JN! z3@q8km$P!f{W;+63huTx{aDw>_Sxw%@In^?pG)~=5Z(a15IjsZcu+6-+hXT)wvPWD z^J2S!cfF-7nXT@B?8)URP(NBOMWuP(~{YDVr?GjqS1o%>Z~?pL49 z{i?$1Zs}=iY;U2nFg4n3s>}|qNF58w{p`x}Sr^TkX|*?YH8x$% z$#3QWxQ2$>CH}gahMGkI$gQDa{-Wg#H9-Rm29{V2^TUg){o#hiwY5uYmNhK%SBGmP zVg?N~X99X6jolHeA+U0hzb-Uy0?K+MwIP^>YdK>RawGlvb)DUET3~}ZGH@MK-Q5Ba zU)S9hY4Q2y*DhWnM*%i~l}Pu74GmU1+|oi;$#gxD&aQ@@NOxPu`i%H(l^YtHS{p2m z2kmKz@G2atp4Tv=d!o>3Ag~RxZ0PM#IBo82YJkAkw_MZpS+Z$ZzoD~( zme67Je{*}|HC=QNVfVWA4TeS=n!7s@F;=s|MHv^6y}Ur*%;(`!EyvS{yIzb-9Gz&g&UY-nzbG-~Xn(fY)ulU<6| zQ!LRFY3SrY${cT#nKZR>wq%oxawlR?kr!=O-O?E8l)lXDn1+U?jg7*-jqPnWOlX*- zW*pP0*D~@!Y-xR}GR>s&%)FbMIu(s`lIC^rd`hUT>+NW2h^T&q&m!xDbY*0aI3Uo- z+Vo1N6QGD5salT+kcQ@-&W6^;j%J~WG*PEmJ`;5*X(ggrNVcWpT1sy2q>WOK?scZE zJ&4Hm6M5DqkL#4A(xfqi%H$@#&!*K$9ViW&8)SURs2Po+HNw6Km9>N-6p%d%0djIE zCxW&c#Is;0f_g*ewG%okqw$IoP84{lI7#Z!`b-weY3xDd%UGh(ytb#u&~aOH-yA1>jM*K|=potxTb zSPd;AaMH_V0c7nb=P{sn+v#3j5xSo773Vqa5b3%7v7mATyQue+k52MrKU*w8&nEw?lg! z)GkBMuIwkh{EUeznSQs)$PTBaqN+RFE^32kbCaIlUe~unuN~2Z6VnHPa|~^#U4MK1 z-wy5ajoHI8)AeMovTVr|F5M3+39V6o6CSp61#lcpTG`nKOv&1 zYa;$u0~H?}JH739V28~non3!Bo*iDzd-3V9pKbpHI~+CXrT)?syZ#1j-C*E$dfSh| z4u?!cyL>yn-Tpq4zS_jI{g&*|Yw#!OPv214&9sbL^nH8|hwe$P#g!H!G zh8^1eZg%{M?f-#EpDe}p?=YcFhjx0eePhC(5K8;)^!9qI9WJw9nD`UR|LuhIw!erS zu9#*Ln!v`J4ZWWmtpAFK1ZJ<(R;<#DI5EEcY=@7L#*>!b_LrFR0nB&GJ-9J*5W{0+eA9b zOCY(>g57#1`|fCQg0xbI}-=kbjoM`2Zx)E`prGu zrR1N9QWsXav3f1nAAaTbcl6mY;t6L%x=_xS!cTb%D=4Tyg`sJU>t6$@j%@^x^*M}WK zZ+^~>;pLzCa(_oT;rXBa#m!5c9oKgtx(vj0$v@R^`hE1$OFsMYX&=4x;^Qy9WO2)i z<5yID{P>SgJ7M{f6Hc^tPb80uo_6M(#HN4#a&S`nbyNC|OuX>ojYGeB?DNmg7T&@^ z@RUbC<&T?Zo!?%H(?Z;6EB^xMARfy><6+y6a}=$Q5P%kaV4n<_>14)4$h|!5dYN!)cfND#2H+W(gS{Oct~@~eqyyCZF9(RA>b>It?K<`V^*(R__&o>6KkESX z9)5uM&mRE(9}f^e?*MSN9sr+T6aN9){FWbb^K%QAENfnN(PBx<>4|ysK6lxY#q*Xo zU$m@w-n_)T)a-_N7cW@0;B%KOZ(gu$cEc%`E?K-__C=q)bb(8I`;=tA;euuJ zmMysG(s`FJyQGbMr1;u$YXOTvm|Mv}AG9Ma`h03;b3Q!cq|sWMDW@G?*EFSq6=PCKii zao(j%=-CAnv(QD&OD?;l$+4`9X@bu#X@VyfUnG)|F%PAAk=SS6;+D(aE~jz*en3Yn zu__lYS4HK;4qU3Bs-^V#rI#+abQDRjo97T+ z?f`!l4!dN*G7+Z9k?pbtmn~n=oZ!)P*;0Ef{l~;*fLYSS5N=v=(Y%G1Feonh(gG!3 zw&aU&$2=8x*v-4_qDvMh7A{+`AaPncb@D0mPCVg62LI^$CtSVLPN+}>0=Yq;&4rc!o`W{{MAqR zY@j)Ld~UY-4@=C7^E>>Yz-a!Yrh3b-@{3-(>0r^qkJIz(fxP}+TA^HtL{+Ts=i>)H z=;BM3ik6~)`{l!fOI*BkRtPlu+f@)hel#|b$QHyG&ig|J@kbQoA1;W`>%vN2vDnp1 zqpY3zBCQ4S;*0!mWkI|v=~7k~#K)wugtZ0nwr-07tt*HxTz{-Dh!;-z-^POYJnfXW zsUZH)d}f|K1@VU!#P=7(k1L2DD2RVoLHuAryjKvvs~}#yl>cQ5;wR)Ic@7oCzq=rQ zxFB9@pV433U!uXJ(Mb5FApSiC@udavWd-qN1@Z4Kh%YaQe_uiTuMhmfBws|Ivc{0|oJt)9?J=p};#7c!vV-P~aU3yhDL^DDVyi-l4!d z6nKXM?@-{sCk6iG9lghId#=O}$8I~TDB)*%n#YU`_-*%;Y&L{Prk{LfQDWrSI{tdc z)bOV8BBkYajqp46B!y+_$_-ffM1^Jg$@N(HZxxowC%4hUA5d7Pp4>VMzfWPAcyg;P ze7M3g?c`c5e5k@QXXKVzc#Og_<>cmDcuxainZ9z37Jf-#nRIeB7Jf!ynR0TK7Jfou znQ(ID7JfuwnaFab7T%$-OgXuPh3`{XCY;>RULua|Q&^^(+%5~>sjy5oxd99RSYesg zay=IQzQQuyn!{}g=Ip? zt+w#t3d?koYqjv93d>}YTWaAk3d>ZIn{VMgX~Hs*(VEbqM;0eF& zk3)^K)6v+EvrXN9>iv(^1n=O*kH-F3kLuy(Nes2cdS|E|GP27% zrd5D9$4~MHmVdg+`&0J%!I0nk!l(S+;UYh|#oxZSc_IL&#{f!3b}jUdsoPgx__fZe zCppn_+#J7c*5P{fgD0EE`QfZ12xMQQTeBB~;+C;T5l&u6-J|uZeC~1*V|;4Qo4T!b zQzIBo-BEik6WfUuzpmhYqbp&>*%7dx^30Flvjg-e@a`6N>ELG-{Unes z*O5;VmEHLI$jF^4<_Ej|;F}e46d`?xhs9=ke9!OmgZ7GHiuju_WSb|HVuW}0Q-4+k zyYsO9O|6s@=J_0PZ8bz?mnm~pS26oe!M7^6_(5GoRW=JAO1bz=DK*&#;*|MsN|~Jf ziKR4GT#!%6{)=LQ-PvdMjEvNU7gx-#&-~F_RfpsV0Zl~{Gd3^CQiso-9(y`1v3(d>$(56^^vN1VL@%Y7Dr*S-Lr_)|RJpPSZ^P5-PwfvW!RNV2O;e$jaUo@BRR#ef zO$}N|<|}yjru?L0K4}fr_jotnfNV|&Pp37`XcVncqi9h{cEf8Tx#Kt=YPQdJd4)v@ zn9jOt&zQuWsyRJnBpv*uVy%!66e`_B1^VfIHStC^-q*+P;;M}*O1X6^M@5<^m472; z9l|$P{ET;R%FilVNy{E(7}Zr&Dz^rUp|y?a#wa74o_TFd;*K%Yc6v1P);t1b6wbd7 zP|T2lLW2T9h1obxNDV2Dv|aWD;W$qzFvQvm;fN!77g9Z>WmgV6G9`#Ke5zx7M5E(R z2cMs7T!Bw_9*32NjjOwoV!}s+s1gY9@kir+R?*12(rT1OvrFPUt(0;2{G{Rr-n}V5 ztSBcfJN&BfK?oT#KV)tOk7N6Wkyo3NWB`#j$Zr+(>xG{xUB}ZQ^0SKd7FSoXLL)_q zJw#ZS)Pce;33yY!Td|sFHn8gGGy+!RNz~{^#g7tJ&C};nvq0=3Ecmr<2#Lkg(RV9` zh*I((}xWR^!P_(huzuQR}fS|bH&_r(WMn7_0_L>(I;shW9Nc2ttykykcgTC52c%$ zE6RLg%l$h<1AZo+)~XhMLSQxT)&snMllL)2DR0AGzxqM%#t)Px5_c-A2A@WLp<~N|C#qOMPi|KN>v*^BOD|8fg@TPq8FLIg) z`W8;};4n>zJO4B?LPO?OU%*(2YGEEfq+R(Y52nLQD=JezZv}r5!L@g^o%MfuQ#(IX z&`#?}hE8_Pe~gUWq1J)7Yu=<*2=q3i=mu+^##(+5-TYUY_OrJ(ZJIH_?(Cmma!s=_ zMEgp;D5dsAV^_UoXw&5q0rLxRMw8)}@9rL9|7*a6vl(wYyj5qi_{shek^y9bfJ8Uj z4E>Tf0g2Q|?8u8_5_-Pwp0G9W6!Aiw5I@^1#DOFryr|AzBn9Ohnn-oa`9TXgi(d~K zjeeM}SmB31F~RAFKdV?tayq)f$#}qM?#XU?490A`r!o5}kbKFz0IYnFUx8jZ*ILD> zTWZ)YN=H|$F3xQOO02K8?MZs=ms4xoo-tng@0lM!y9u=EvzSyjl3U}z*f<*dswL7C z-UI{&Pk@)wif#guVA*ZZmD;}Ue>X-;d|(%%*R|WuZJS6EN;^SnIF#_G4f2r z!a8o(m8v{$09xO^1`JZ&or(dqFF8QjW>857FWG!3jy~?@iUDZv7v1c10yJhom5AIb z7~JewGrNu8QHR57lF%efVpD+zD|-f=&l1 z`-P#H1Yi@BK&psHU~0%;B!RD-kRZWRBKczIx*rK@lp!Vo*qC#3UI1Eqlw8U_UOnT8*S$kzhYA*a46{3BKzfWf$*$3m2@8Nnon%UnGG> zv`8@Dkzo24pzD4lSXV#-#|3oO{~{OM0EQw#Gf#%SDGa@~(i$5*Z{(n@5`fpJ-TOxM zFD-HZQGFCyMmb`$1AM2}`!L0wA~L6tpXgMv!M>Y7f~$Xzj$P+NXb(CxFX6d}d& znridit+u9*qpifHi+)m}sdl9!(WyS zvpx-B3p7h3)~+`ZE8jx3dXzZ4|0VIT92~_MpXQlwAVtIqk#*_Vv92}w!5|agK8pO% z$@XpsYJZfxxv4CC^Y$Tz z>C4a1AJO08*&hZewY2wH8?0{?)uXc6sU~lh&~DMAYVw>r z+6iLeI|0usKbGF)l5}>%)$!eaz4BH;t>k=1Wgi7c;d-y0(b#7=PC*dLmKinj5^F!9 zohcx~enPt(;^rk*)$f37p^UD*Lrc)N5J6H}GuW-5XQmFD!eSyw z2EXmh6-|7zsNRnVgE4dT=oyWDlIhZjF#c(K%M)Qgv3*?u5%v???}w6kB0TRPWq+C* zCBpvV`fZ3%D5Y!flmhz}B1lea4%-NgA;QgW9^a1>e)v|w{Z}~QA#fBY+{LpFZM>{L z^ILC~*4>a~$J0g4k`y%D=_Lz^5nm)Rc@=0VDwLO2qe7gx{9wp0X|nx>+wSZ}J)^O| zeri-of2E-1xfBw8HR)ZXLpdOcIBN>Bkl13Bi|4gXc@10C>xsKovP9br*~e8~*jzCg zV5Wj*k9peqq=&DmQF$k@$Kg85rk6F(xBCBWF*+!OYv7DcR!6YTl<#OD*ayWFbeb`s*| zr-W+E8(L$G15Lko*TMM~XJ4o4e1mRul*@k2wIKT`(x&d1`pVRi?CdAi%(3V1gFL4I z^0VJ1Z5Ccx{57X{$sB zerurYmoW-l^+hDRp|B{)VpemBvaXSo_ru#I#<5!r@NX!c+>uWH-j7aB`q34W*j9MB zAiwz4kH#JJl2=;XM|r8>LWC7o@qK>v)|TI7Kv%f{V=T2 zaMKQA^n(&bWAQ0VhiCZV!7;3K*rq17Ws_KZCi_iorOM`QXlqo-qBdWTsQ4N`c&%~H z$nERNo1JtKeG#rP*l~fjd&=Kh=-Rr_1k1`6mTZv85Nk@b4JWVqh#xhMOzp|U)VPh|8lwqo-#lUIK)+~>BhkdK)`f@H zvp8IN6O1GqS}Dk_1P^Ann5OI0zM{6(?y*)6P=&(jV8m}KzLo+5qBm>lDiZ0gbj4gh z{D&H!miVkheGz$3S;95_JeUyD6*HB;rbPL9skE19VjmS@+62aIIDv#lV@LIJ_U1n@ z-W;Q_Keq4>v@v)g6>Lcdec{3B;KjOVQ8N3{FOEqxG(GQ!r_`j{o=?7XG8~sp&w#I* z-vhqs;FatTfs+ni&EEWkbgUX-Rmc?kb5UJbd~H3}vP>iT9PJi9ez?2_4F33p`py^^ z6tZ0{)|J+=*7diGjA2saZ>>xY^!q+WT}RqNZ}!-`X~shD+_B%Y=JYW@PN|B^h-yak zB>mMUx^FGkoKB@@RJ!s0UWflVli|ZYONvK3d^q+<19?h$%#vZL88UXTI*CpnVZhId zzO;90&%)IV?5u-Y>IZ#()3oatwskMUrDv3A!1g*3va{vkJfy1VtdTUkPv!JuxtKd0 zjeq!Yw(w+sg)<)&&qtGf%R`(x{dc6X%l8nE&nNX?V3F1oNSV4Yn%23!~~h=y;Y|%f%wr~PAFjSefAR8D`thvp1W&gM21)F*?D0y>14y{ zh3x6y7?Yq)pDs@ayUoa>b{$!fy@@hvt9D*KT3q2>_ZsztRwHx_?4>&E-8cYuro+38 z=fm5@pXsJu4VjUv+F>atFrAfkIQ!sZFqaz;3}|sXNYN~@KVtJ9HVP_X&dI5^5v2E_ z08T~YPHG7DHUtmVPwh!X)3&9yzmV$vL-EvYr$-Zi4MKT46qp{g&?}u-k^;Gf-Vwz| zAb=No7xdL)Wg8FCdP^Ishgt^H!E1io<9ln{p2lvqo1Ixd`nx1`@9>j*UaCbRZ-*O; z`+1#EcYh*xKRIl_7w#0T-2x33-#4K1?Lj&$WCvlU4QwX^Mu+z3Xtn|G2D$`<34{OS z2>-E&7mW=c6DPz2>lHufWq3iw>^aMfL-HdmOcV?)4Vi-DSd!p>aYi1XFFVCB4i^^b+f|J8k{CaP^GhTfFw) zX`{HUkEwP0l`qgUr&PVH;e={dM6MNzOf!L?HU!;s=~uHDaNZR6(E8vA-f4om~8) z6O0!W_u3HZDRJ_#ujK(yeVgjzx|S$V@rmek; z3kH=#O4T+}8CzT|zTcnj#%Z6DQV_ETh#`@d!&|L66Yn|}*K z?BfJfn#ucAn(v{n{B=$kcWq{yxAGR263o$)^VEqZRRcO(*C7yhtu~f$8e?d4bUHkx zl7^gO%HTRByXjW5VN_fNQ=5L%H10YmV56Bqs9B%^jrp?(ZIcq;Vv*$JXvlmV-mWo+ zYMf*OM6E$o!9!zS^5z!rrLHll>K^9PQK@7|!PZv0!>RxY$JJpd@f=G%Fxg691mmvD zouLhUH*tnlG01{xbHrP9mo>RR)>~1Y4L6DSrak~U-K?n1TIuw!yd1Onq6aZ?YKb58 zOT<-4w24|}m!C^3g>WoCfop=z+wh`abh|`pI{83t^~8Rv?QFhH0henH!`21*yP=mM;U?R`cY$$$%(QBPqY z^f7F#1ifJ^CYKvpTGA=V-1DL3`D4HG8%dH0(sLFSta+zy%l#c2-Kp^88Ws+7$m9oA zsqia8IThYyLcHl(Q4N%?Rr^v!*NSs^*v!>be2r4nFrutAMc1k&pitZ=xYSxxk~>s8 zf%}Wq1JTyWvmdxYv&MSt6Hs@JYR`9g(Hhkror<1I(!EfpHXPT=NNj&Uy$5#)AwT(y z-?YVVdNI{B5tY-%4{Ja0eGxhj8M(h9l$q}C134pL@@G1VI~JFfa{s_k{AydmoI zqgu^(hce&wr>4BPkAEm^q>5&0YO)@Tra2O5zQZ@wEkv2``dW76g+yFq)4@`1P(lvc z3Hc@P;x2XK(hpwD{_+x1@{-;6?0#!IPytK$l%Qn$K56%LsWK~`0`UAjc7dVmUlA{Ul$`nMlueWMvQcL-vNF>CE9 zLNOY(FVvoww{Q5t>u3#9qRv|6ho{Z23qN;7I$Sar(Bmr7;pL5f(~=d=kLuNjMn-Cb zt=YSOWh(r*iU9nI{1Ey0PqnX(RB!ig_y{A_+t8o9uP!Pst*h?yq91{?AAXr(y1YC( zJ(&*AQC**|Nr%S}UF8SUDoA23C~ab*EnPy!D{!a@zs$%j{dhw(?vsAg8*uC!rpBG& zH-v|zq)24816Y%8(+{GsX{#E7Hkf^qb9;Mcei+xR;^78A-V7@(9xjZKS4Y3kR1L%k(S+ApXTGN z2k3DX&BwE#5Yo~*d%t)L1wi~1pP|D#7~O~U4bB-$Q^|Wz4Jy75dzJxWpWMkk3ozDA z@XFL3x%*fS#C{Cn#0tvU5~P;IbaGF+=`}p%cBYa$&WI*H6wfEr%)GW=^Je_j=Bahb zzB&w3J-PS6n+x}i-~SRnJiXoV!-gIIZ}7v1X(#-UEqDA-Mf3lU@xyNc_TPvf=J>&r zd7elGf0l2sO~T>zgABWLSj9@bd4?Y@Wuz`*ab3ee?rN00o09dTnfI2E%PrC~BX~j$ zXOA0@sbH%)K~>?#UmM~jLZ%cubDMZJ@YI~E3I5WG#-P46MUHiG%y-S$oDSx!^@IA= zN?EHEZ^D9&4dGAXt-bn{N?7d@ZmR?tGH+5vS>l5F_7tNM`*_ADN$>M{pBumXyf2O4 z@yg81kKZTrF6TkzF9+Uwy_6BTh)684UW)n$fbX~M8uF*ylL{VB2M?x$hILt=E=@(J zT8i?e=e&Xg;wU_7OGl1>OB*Nkw&AOUS;7_xfOWL+~gK*+`%v_(M9p)!GqcdWd*-qOB*OXG8MI+Um!= z_OGJ*)n~S~JlBwU<*Mnau&q@Hw_UjjZGe6O@n~Ywc-_nBni(rUJmMdQh zGoo=i=*&_>T@a~0**9MyJG~@IXAiw!ePlTRzCMYbRu@{%RCr2hN_OwC(#wofkv8jC z7SmH%OsB&RQS0>RiWf@QCBaf&CtFBq@dW-H`5qyG!D=&>r{Ypnh0-*t!Y;^Tbgj;) zx0)xVqS<4$SYmyRy7n-ma6)lUD#QtM3r5Ao_m9EbE*b=T8nKIqA6CIBYEJf|>siT% z_RfH`!IDNv`2H_#Qn+#>P+eqbC25r4Fb_Y-!t6m!pWgKmF*LKv54*&DG|308uq03I zFcCzmj0MF;@)$Q_*h@#_D*dKjSkaB+Bx}CzMU;f0GD6c^^m5io8tmL84jx zT3Pza=t``E_e)&KKm!>{hhPn3h-g|BYssoozj_ZN<$2|)@z!iTJsO9nr_17K61-O9 z-LmzN2mLTo<$hZ(>9@T$#`{`tP5WzJ`x6XTdM6=30ua1Lm4N70Eh<@4Lav`_0qtZB z3h&er43o4}q@u6Hx1;^~N&0nWwKGUwu$7KF$#2_AxAwF=PF6!b>=tuVh45+q5Qu4L zpvfMZikio>Mnvn3)yRHWcr6`QJmC7!Oh{qN+H_R^OFtUF{1<51(X1PI(Dee2&Xo#Y z4C;Rgdq~xZ>if;SOx?yA$5~(0jx1lw=-x8YRYMs+ntt+wV-jaK);f#R*)WeXXX~oq ztgxY9)@Qh1@EL3HntIy{UZ(euj?!Oi?=UU438x|E$#iH!ts(eb_N({7FwyaU|6a|? zyR-kYO{|2+H!YNMR=@FbYTKRt64}C*{#xdl=d8DHuxIs4!K=Z5*RW^E`%yLeYUX(?|{B(Yg^g@(LjW2-DVL9C(iQBLe@-af&D_Q{zNmPB+KAS=PCcmhD zwV&({8(M>L*X9aAnUa$9Ni+-r_UUIc%DnbPEDy~5ne0zhKg_!2 zR*T5X0$oMQ!0A`VI}Sz~NZN>$>Ci;w8By^wesT!LDgg=T=!jH0aRMxqTzE1D?$UI! zA9*o=1ej>@!mr-jGDzo|ya<{rYq=D_OF|WXV8o z0~z+U$L${+(J!Y06LPWWL+a%+pNA%4;e$$D5 zbSksZhJHk`=NFmqfZm89KlzdmGy6e@jf-f~cUVqgSKgBSK39iQslZDbKsi<6hn6v= zl}Xs;6XVdQS+`aa%D249L(|`m2sr{^6Qs0^8-m#$_pa|_$rXKJ1ncOk6SM?xVgfXx zNg}j=Oi@9HHDmh=tnvm*ruL+RF4sq0RYIZnsp5s&GJt!}AN#>=tmOzzJP6c!#1m{j zFj~hT*AXaNT7CtdYFj!S`#sv04h!yui@{NOu z8`h?S0pAG(=)`IyKRf+c>G)~0L!)yvLKtzX!-MYKKGIBnA-4q8H!Tj*QED~VeZzVpds8KH8#l1w*I_+ zW1M*7O1*d!x;2_o;XG;7WiHG5ILpunkgPb=qjsf(2^Kc82p%l|a13i7HvCmUYP zUUM&iqI%T$pY9?t9Xzw27B77zdm(wY*2`Hlk=@=WE&kr@KW(OmdO@Kiue`q@3&}FJ zQ_VtxA=xHt8A(2lPJ$vRJWLZuT-&G!;QB5#9flIVesr1{ zFg`WtY@HfqX!E@dQ=UM*Rin?s&nq2tRFO~@oh@ZKL2OFK6Q?MnLzN0fk#!CO@gZ$~ zIprRxV~}F&1vSX5w8yZ&JLX5%cXDmY6SN{OJY?H* z8I$U54`TGIFk1&gj~Z;!L-we}(&M9ITS!v%QtCuO)AC}7*EE)=-Y1093QK5Cminv- zQ1g?F(5{3q47=3tEC5;+imnpsC6>EbD~z?g>Tt)ct9hvpeuY$Cq>MrLe0yXj^GFAS zTTLz)l`;P}WPa-h4|3jg*!NQXI@BvFWae6tA;0YbG(Rn1x@w5QYK1h*H0l*qh*#fW z4y8Cf8+4ajq0Qh@W^Y}kJf1zu^o!c4u7VZF%XKquT|q0n_QOz1YJ+=1)95lIEx&hD zIMYmf51ON!Pq*|?Q@{#-A~X97mb`WqBPL|GWI zX)9#!`pd15jSh26NrmTe&a+;l7GL0oA2K3Zd1dj2&~yA5IBCtgoAuuF%80z9;k#V7 zi`GEcSfT{foT4#=)>(*keLBddrwkF(!?+gMwSI)+#4OHI0|42BdTq*itcTgl%?l}w zFq+E5LtjQUaWgy586y%PqFRB(XmSbpjU1Yq?i)_eXjt9+Nrs(Zrvq)1M1#DFFrruX zRj3k|WroNO-fcvR^OQQ8wsr5KO^K^g2&dJ;x~*H>>(+*DsO(!FzF@;VQi<4(S2v^L zTCe?GA`2=ZK4Vut&n&?Vaek(sNDz&Bcxo#1u74WjXjOhNg&iA7N{3}})wSVaNSbuh zI22P`6Kx_nuq6ow#0Szvwg}L)-)53VVncNCR_WGt1QqI@Qzlv1dYMNMRA@y50AcR7 zr4n3xBIf@Sr9fJbI>w@_Z3V>)!p2)&vJ@jft}0VYSnX_K5h7xGxAYvs_~@<#+?X2g zYg=mChrIT!)RBipfieoJOuE{LOPQLIEnfRSD;Kg0FbD_9nW;TfU&-r8rQ_H>*rGLV zuU4(GV)RnWW3duL2b<8TwnjHkp}tm-Kvqmoq>?Y9A!>5&#cSz;Vr=zh{(uFv9$KUt zc=l)!(tH|xo!ah5=aR50fCYpATG&yeqvy17}FSX?I1%p9} z^R_=En-4R^SbOiqNE|oRYOcS17`xwjbNa+Dt>S{p9W>W#4)&R!*ErH}7|K-km`5 zHkiim7j>3{G(En*AYn0lT9ubMTKI?2d^KJ>_p6Rl6EwwN@kq(kSMZ&gx=nPD-O7{Q z3I`7x)3RH|j#eogtr*m1{m~);e=A$ltV1B+Fmjl!JsHdeepVThj4p1y-OfQ%N2h(X zJjXEWUI#fC<07eCjS+lnc}22uV5EPc^mpO*5y&dEj=)19$(GRt_l}Y`RsCYiZ|Gkm zuPuxng_jKryOWa;%9z=f#j&03A*1y`?o8z=q|SNF_E2Xk^h5)U#11S+@RxDsPj`eR zg~l^=n`;mF$xrPgkS$)vAH>FgjNmB!_O$HGR}(xSMXl{|)`au_EDX;ShE|iG`~~2O z+0DFw#h&Q@aw0c_Oe~!2u8y!nqe_-W)BepPWuJr0bGhFs?~dF->TL7^=t!?E;!$AU zaC2ayZbrG+?rGbSAt=j4^?g@8n|lp>8#ygp0oqL!)B_fKVW+ zC|m2T>G5Y|62y3G`f5uCymp#0OxG=WJ40~V8uZg$vf^=UBhW6X;OTN;ZY@Wt6Ge`+qJ9c0bqEZrL z52H|%5DhD)Bh4ma(^kK^+-{Ad{OBCSV4vc~?eyFBAPoOqqpi&*Vh%q%SnGYQ$KSpi zA=vwLaeX@;8o22=OuY#e@VKPK&XyNI%5Qr@T+)1~SYklp@1b}qWbJ?MPbJS8laA(L zR0VeNOeguob|Js);nYms!=L z8u;)t#V=BS-7kijba&sWxp(}pX_$uh#IF&@>O z4)-#e2J!oHtCwizp?;J;6q5eJkIpD{O3{Pfn%x!X&-xmJ^z~4dn)E zAI6_?o)b88d!hVcayP~FJeRyJkJ8(XqGq*CgU#=UmwbhbGBrHtF67}{8674h>w;S~ zIpzKpmxigY{Y-w;Vq+dtwhAB*WrXS%i=qEAMxLu%VnzLURG^Ze;YA4NtVU7-B zlP7XJbbvoD;xt3xnyjZUv4LPR-)2*Xn20$PH$FcQW_dHn0A`TL0htS;#<~N!H73}{ zy-a5zPgJ&4WyGH)+NOU#_XXu}aslCJ8L4lNWgfe>OO~PY>)unM8sW02M1+w*W3wI@ za+-KJx5dQY#J;ILssU5c+`2wWOeo&$RB|&PVC4C!i0foA99*uD>AU0JfCE^~Jm4oE zrgJ7+wyrWBwcbq-)5ZTuI&W2@&gQ0JIg zb^;c+wF-D*g;R&Xd#Tl*X9b0<^YW}UFRQ}(#H%+)5+4NWJP0vH7yuIn7jc^+FrYS#q z$KLdgy@|o2S>gYVz3JS4qo)1sO{Z*-O5kiG%&B$w?J*ZftwNTVnjm{qL_x%oh5sAd zn{EM3)SM;%hK}$T?M=tmnv(OsX>Yn-)j3<0>`jYqGa|iXZ+gexr1^P#_6O2=r@zJs z%iEh?ChEUxZ`xM&U$QrS;0GEL$Nu3pjq|6oAN&5B?M)NN@L#hxT@I}Ovc2iP{~=k# zS+rI(DqC?xlm7ktLelI_cU`OzdSH9g>lBwn(o*~XA$!x!>mhl(a`|s>Z+iNBAp4HJ z$(i%su{YUCr2G|o)3OPF(cbhyAjI~j$)6FX@7SCE|6*^N{GE5~O@Gba zH2a^iH;w$W^t}HidsF@_0=JZNUg?_W`eio5=LePT@})YRv`A-{SYkF~Y$v#s;9R|| z2(Ony$kj7uX$$2AB+viww8?tGH%HDu^6d{#!xcz(UX*@Y29+%oSxL$4c7nt=>af!( zC%1l=Fhq>qi=JU$!=0CqpT6o_M}29zpl~U)Rs9s+^!+Kego69s-2u1@rsT&% zX6;V<+n@J?;tJ})TZOA~-R^UPZUVXY*(%AHkGz~T{o4}QIOA7k zPm<4HAS(dpC$cw?lfIi>fkl_QAj)FrSu}6<7%pVf^0a#_XKA{qxuOI_TS3E|V(MmG zTv6$@>v*mFVP;oUWp=c*>d;tCc1x$U*()l_**o2u3hUW-VgIqd#>@PfZ5zDtUZxbs z&S#%g#)jcZB@NX(8=~_{+3?w%u6~$DUwz3#Ui*#OeFMzoG2W^+-sOzFW8eO&{IADV zrP#1yKgWCyJ|ze2RP{6LuX4BRT(A8NOfY^pu7VwqchSIN+m#%Y>ACnZ``$!4cs4sI zY@_3Y__n^>H&sS=8kpa5T}9~^t9j@C2PlCz>M4ynZ_pGovRDGfXMan)Uj(DGsf=%P zD-8@LUc&`Q*_FW0F4v!b7g%oon@M z`1*#KG+!KUx%aVosn~q7v3Xi|0Xd|^>FDP|41^XnG(G1Kqmvk8aFevT2ceFjd7gq?S zHWvC%*=4)pmr}3&%WSN`FOH09@Sv^5D{HIoY5tYpG$4m zbvK$+X742@r29w(e;EAxxHtrplA9Aly!WP(J@tqDCS46CYkE@E@ZT+c^@j}9xA%JOf2-aTlNWibj^;hBZnk3w z`F;3m`25IE#^($+Gj3;5U@P~X^tS9uS6@-#d+m?H=VwIe>6|DqFPeVsv z&ket6ybjj~M_$8SW;P=Py9~H<-AK_ z^Dj;AOjYku3>!FHzCeg$8ehYg{NdV?Jzo2Xu#!=(#9Q?ty;Dw7(!@mEUK*qQ_zEW` zk*@wVe)UdX+`mWUXyy`fo#}m(yx3@oH@ImcxpV3c?YqNoI~ld2 zwji?4%l^2yw=l}$5b*g6FL=MdMnyi4?~&Zlf~1UaUaEMiSQ9t8<15Pg{Xa-B+pbG$d~Q zdY-5j@s{^#jYO>@ib=7)m1hmll{_oSvci>`%&Y85#Fq1_t!gUSrApd**x=pe4h}w{ z^Nrb?ZjttJPxkM>CSx!M0QadKbyJ2pXZ>e8XN_Er#j!;3Sc0|DS$G{@xiQuBYC61d zU6MoCu`hAAVef5tHK@NCA1N;8c>*+sG)GAYhjZ2w)UGyH?qjTv5{AwYnObQ=5_RP z3ad5gb)cp^U33VyqReUagYHu039nqa(vB3cZEhaH@r~S3nNqo3316YWxpC^Mr3cv{ zeS9w`@+d!<91W;5-dO{@TEECyRu4E?vxL$)ftxN+uOU{Ze7~&WS8{z5^8_(v0Ql!5}LaAP9Dw5zu z?0f6j$bBt%JV1P021MTKhLz1nLmg3)tFaJOeGEo-g1&gC=Kjq-$H7uzv=Zz-k9IZG zh*MojLm0KHJ<+5z4kYLL(X8|SiTh;Wxf95!ynrE#U^0}+JbYR;Ss zz4Io0>=q`3uq2$St1OxZxPr%9b&z~)qA!i;rlt176+ndy1{Zp}@mhf|QCD>dS9}i3 zw>GhDk5@t|B5`i7kE7UADkBv(I(3X+{c1B(W^UbPWLxR+OTiVH!xTN?I8!`gdAfNR z^|Q~rR$KRO>%Z^Hr^9$)I6v5+p;h;pydTlyRE61V$jiB|*ijZ`+~LJ07vA;*##0Tg z+0Om5`Avs##{*YuaMMV}6l~{_%lKugUuc4jLrYCNL`f+_xXBHn8T>x`A2*v+XoZZ% zWm}6?oO>(YkgTkMY;QiS)~@vYJp;&LYjN%fFjIcEn{0p;bu1DiL=(AAsxvI!glP(lH#KHy~m_KBf8?N z#o1oVtiwUBKSG0?`+Ew5=q`KcgxDi~l>PQ+ME6cnc?qI7+Gfwc)hY zn!fD+HeT*N~MWT0mnCsaxeb%rl&QdX?pL zfWWlMRZ$9IxVcWP=2Dt053c`NsSt;$Om}P3Sujo+mcT3I+-O;TP;TYg*14Q((YCmk zXFwsYPPE7_ee#T3oBA#C_FX)H(rQrFtXC+!eYHhKt0~Scd-E+aY_-Tt6*+a6kA-eq zry4jQ;@VrLw4i$v2?vz{U(3{WMP$SnofT^kh@E@v*jwZ!U< zZ;$#$tIOMOC7Wu)qTM~#cafZdfnRC( zPv}lqu&Y&hI6s>Xo63O&n}?OwmfLIeK>2dTmKuSY%BX$N#Vm4kWM7(N3Uw78olvDB zv4X59dk=1%O93w1z?i@)E;K^~nNq`;so=?dkwan#SH8!UcW6W!EOA1A0e&v)x_r#Z`Krn#D5)xVTqnvnkVf(B z#E3|i|E68|kvozWMe~(6=*SMEKn2^K8#PKKhv6)y-xU3@65n*r8)qN<%E*YEddF~m zF1%nJGj&Hp@F%9gVenY!ozN{_l4B0R{E0*H028t6j4hZ7qS=R!1RXjez|BL4Q-8l| zLrdp%zId_s8JTd9k=zT?(PN3{fuO$I^_ubspz;JA8%g9~Z3oOJ7T81(V_*sy%=IL5 zg$qS+pC%aj6eD)M@-RUg%XJJB*?{KH$vR7Z1)ppG)!&o7%%!BXCcyeBFKS9preTzh zCCM)1HREaO9Mh2eg>FSL5*RyjSD1O$gW{t?kz-})DG$TiIFS^SC&HQ=rf|W zHHDg1Qiwh%QG0cgsZ*G-KzoSOjD&1Fdj1})#RIAB&(O}f6aYM+6O;jm6kgyE4l{Ab zFu0&;sc%VNXN~9*sjTW26Tm#T5W z>i}D1Z?2`?LqO&{vzB_Y@4+-Htdj1becc9R8rD5b4658F($Qe8TjbcT>wZCaDbY1v z2j;=) zDZj`hwgf=LPIj@jewDhZeq`cz==F#cc04!Z6T_7vE?;sd-H_4=#>{*H$EMFev8;R;?Fb^XeCU{LWbDJf&-TC$)#RPE znNA;6(;*UB%B)GyCsQs=x4%GFtT5nRWs1PEDmyD)xrQEhV8V7FV(djfmMRmcZB0gX z`vxu3s0W0xK5=$;TC_>AsL?1n8a%)pa=5Q{O?3|Q9FlUBTdUYt2T?z(l+70EnMNYh z!LEkjxrX3nJ4w5licCU=9hzAif>()lCr*OQ4+TnhByxvpM?YYKuI~ydWRg zi4SowMW-LO`qdA!)lyTk(`!GwQU#rmkIrMX@8Oi*EFu|HWq@}l^&VS|Ep=vmOm8M< zNqX3A8EAP1u9IZP>t4t;ACpI+C^H!pnEE(p5N3pqY#2jfW}V2q)s7^I|FmrBvopDw zwNw^b#E%rwW-~|Ps%g9pQ$7hf*D~>YnTAgY3qNO0z~^Tbw-yLUOVMZ;{%t z2>7e6XY`U^Kxn9X7Uw;*rn#WP>U%8@5S{)kdTlzmZN3mpKE|Q_mE=UCmugfcUuWzL zlGLCLy3T~+!p<6U(5^0Dprg9YOdXv=dJj7n2_NK%g=|Lmxn;%nNV*4rvl>rTH3#ZA zU|oWaIcPv7nr2?B)wR7&`!Pe{HU7PbOYuo8a8JbO=B+xI!W_Ar40*ETg9{GvG844o zjFy*iEz_@^%(7F$h>AmqE;%zwAHu%HL>uJkYOW3_p5U#?Y*IZlx_9x=o<-fEk;Swb zqFkb68S2_C)@y&B-T}}A&QCp{?CBYHj)hnD?zVgF_pA5ZdGq?I+t|0GiIsqk?eYsx zfhkHjQBnF4FW$ksSD!0*SBj%Gx)}?*m^&CVqpOr+&3}_l?n)=0I3sF4R=SkC9}CN6 zMjc~Z#d|q9@e@8xSITI@<_hC!*c4yPPMTyc0U7I}FynfsOT3USx=k83tX$$J-Gv23 zozgFWS;Oq;^3Jd>^xBW7RgSB2CtK%tWhELhJ~&~>SzwcgY=hmKZM@dhzsyq%jdbvO zc2}$F>6Uh#z=R-sT9{GDZcjO+H+g z9ICC};zfI<9f$8m0qJ&2Lxa!Ld>l7PwG&`)++u`oYDsC3rM8MIlALSqR;v?NeFgCqgA=8;X2h1jptsx&715Emlf`HfP1_rNX$%_C zy=BS}bctc@#?@&P+`29m&Fm#!LWP^gCJa%b^7u{fR@+yI>54j9c`%l+wH2G3Xo%{@ zYQ;Ae%k&mErUigK%Mvy!AN{0pg(%7axd#bxcieU+29CZ?bcZcM>k0VlB z7}A7$7}Afo{En`%j;M~*zm-#T0W9}@Hvy-kO5AL&~Wb-&Ernl^dD=l{NXsq6{|Kws9!I>_v-m+~j zwsAC8Z`sQf8@iiIxQlFT_5wxhZ`<8U7qE@ilRHtOAl6&2`Y3P0b>D<_?iBUq=!69- z+{tKj)qAc`Eg5mXKC^=2T>}G9jBdM=uZJBq#kk!7h^F*hv{#nJ5Q=gTb@M0k0BT z9WojDkzM^LMb`b0*D#K#U()emsw@SinabZ-`) z5U?U_E;xHW<@P^FX(o8Ch2tRQKTt|nc2XC5gqp#nU>f3d8?BX6((p0k2{8&-t+hwA z$R1rLI)gzrg6-@g9zQlA>bPvsIiLoh&4_9;Ky>XAiecAkm1Ub$kEpm?oarZpQ!(P* z)=w0+K0?N+2!uAu=TEe&nn3|)%`Fif%`N41y?ZU^HKEtAbE)O&&I$$TQj1ei9~G- zWGaaZGct?tu4*IGp-Guf^VvhSFUxSrsMLO^b3*gX-yCalYz28xqwNEQ%wH<69{DpA zOGWdLi7Q0Uwbq=-t&U9GlUP9C!L2cNg$MuvAoAhT6nk<&w00Ui%tGjVau11{_WN8e(i8M7|8@-F-=%4Jw$V zwTbu$-#43KCWq#U>}H%`TZVjWr+5l)9PLeUi7J=QnEWs5s?w+{iZl(UXLO1RUglhe zAiOE0VM8$w&2vQD!vbKg;$`#Mn@zuwOoW|Umhkz(mFHDUT`1*mDm((F*ku50>w%^1 zN>ve#NrktViraML*O_}dO@0-1_9$zc*_7#p3G`|zJa<%$O@|!b{`(5sKz`IzSUyC; z@?~O`E}V#_Ssa_;Co;L62!lqNr~GOxB{q{wA@yh2EBAVCsXK&A7P{xtU1Kg+{B-3)!~vaK2K41S%BVx>z#-Ugwe9atrB^0S z)%FJ4ySfzcM4cMer`~qO9StW9X{1zlt%g6EkA=!BcuBFK;D7Wf(2yv3l^(l*8y}ZlBVDGB%Ki_mrFE{4wCStw zLwEP%|H`RPY-*zgR9>)ABA_TSSs-=b|+z7U(Wj!>bLH`o43e!pXsu zc5QVZp-%K`fs}=%jG$Yz$cV;X)uR65F6dXZmcez%&PyQcIz`Wz_hI&nKTIj#V5xZ{zku&yLzDHI&r!o8bIk=Z} ziN|zdRvp*-)n~AUJuDN1Tezf}9%NegbfcVI2=(u%X>=y}braNjg@XI=n%Vvg9u~#> z`fu97bcw2^H?Amijy43x(XJ?=NJw4kM_iUrS)%7ZKN^HeqI7pF8h2Y7(Cdj>v z$w&-VLZGd?kq6V`I));lEFo6k@9{GK%07MmUK6Z5?p_mg)l_t*WE(!F+mLXzCH-D| zrwGhqo?*wb?M6bhcrGDXWqNG>dYAsrXkWQU0wHGr!lA=6yO za{B>9`ceYW9_PdOZWAp(vdS3Q{7+g(f;>UX4{^j>OW%lN@rgRZ_QFZ-E~Dw`;Ih@; zl=!sgl1SR4098>^ete_Lm0_!HLPsehiEj^gl#?;O6h`@5Rg*jd&CpF9B`$xr)(PaB zOEKk3Pz(VVFP_vO@=6s#f?m0j6s?hHf%tiJy<+#IZ>`r(Zi2OpR!A|6Ku8C0m^dVz z*o3YXD`+A22|uuVf?$9i zU#lvpvo5=82_nA!hYSU!AixFRS(2$*g{1I4^6UY|T88iz-- zzC%NXT>>=9z+ar~hadMcT*?F!&oqzeQFCN;I3A_+~;DZ z+jR9#fl60f1r**~U-F38j^~`FPgU9w^kcbn+P>;gp8**^HM3uq>hHt}(yyiXNojiz z#!PJDo6UY{c;m)J5h@W*GL755qpj+=Vo3%Nw}8~Om)z-eoFj8I_S(zF;66F+^_bP9 z00b}EC#c{u&slo*Y)J55O$dIdfj7WmiToy?jWwQEfbZu=c*Y8nHZM9=2oD7{ImW6 zbq4Vvu?5LXP&(-5971 zPSJHq>c)8CwQxCfR=iU88=1}VO4Zm(v6^0c%4kpQVG_(No*4}VO73GUCE}O zScGvcJ7&7+G2Cd69)d}<)H|9_a*{*#22E-B!lv-JjxU0{>sYCu=O9$HQFR-khG1~& zj@0%nTf25``?LvC9}Z`&jONejWOm%iqHEMr?4s7{F3ILRVuVy?)V{XVQf zTsg|N6D`68w$gE2jPwzVA-~B9?6wz@+Ocjg{#!M~SxABxoo{Ro%c$ z!a;U29-5sp`T#q&ik)}-VzNpO)59{m6%X>qOnly|j~`)Z4yvEqY>PhW+*hJ;WnN~1 z^+rYo0e%0o<7Hw%>+){cJIQ=kinn8R>s_8j?H!=fRCsFXRuhq$6tzIe{E3X3Vg&=# z){@JvPoJt!T-=(VLAu_a&NkJPDe*^qU5D9Mr1gUf*M+uo>P@L{6_hd~z=T`NC1Q@S zZRg;^jijztY89!(4(qXRa&L99B`#JoqVi^ePu_meLebF7t61?nu{|zU)23qkUF-lX zM_%a~iq()NZ`Q#bgfSGWxls^Ytds(XGFd4a1+hWX8B$4@yU@F|512iqVbxT&xs+tg zNOed>*Y!Y0LX)YJkY;I0=oZCB7h@Ya?j!?aN*VyrOgljD$!0z$qFWfz=Tn4|s(>r_ z#mRij!^^xIlRcxhAvEx)`!Xvu$=>G1tT%CiU_G6i&uo>A0O@G)`^x``&4Y9v$vud@xqHyxhE|{H8%hLYde`m!lV%Hvk)= ztHbxz1@FT}j@}D88%1cG*xRq9UNixp52@fV||FGGH25R*w$W_lU=0I~LElyl@4D^}Ir~{ySe(EdPyPFiU-mT--1h)H#XE~uw zW8w{Kt>s@8??D~eJyB8@0S+K*)u^Cjli1WP;%yh#7Vyk@Y7+e*?vhCqrNbvD&P700 zWICGmGH}tjiYr-Uf9&m+@b4=fUBasxXjejv^blFpFuBf4yJ1?l^uGxX{CkNQpQTX*+B zKU)2l8fJt>Rs;%D}t)G;xaAb!DEl&!Z!L zB%Uz8v1VmqXNoP(91@J`@P$G5?+op3V;zmX{JNIGX({IFMv+~FN+`nXK>k%9435{o z?mJ!ZprN|ePD)X;mFi4pFMUX`S|*!)HWNlnUSkb zj15LqUk)m0yEWj(S7cko{B=7z>K70jjsFmd zX2_@{%vAhw3x7U|*+SKDfN1)$MAe?xn0^1rx*X%^yb&Mn;3)3CZz>foArUZ*REOdC zTJgbElMqOaP9Vu*hCn)Dp7^-Cgjv@m`!0Dk5{G1uWGM-pZp_;drk?{IFuaXTrd#D? z>ATU%7|aP%>erEM`h_OdQjL^oR?F9A4`9UZDM?H|WYdudsL9t3;am9=M`} zLSz~yLYY=Tf;XuZaGYjlGD*82Q_EU%rkWFDmJGgB_Nz7`m zenvoStcUeDR(A?HBBZY5trIqQh;vnR8fxK%tz;Gln%Sb(L}z~1#|=iRiext*KlYo3 zMi&?+jpS_UQ~{3kt(HRiwfAH8=&Ypbw%75;cpPwuwDyaR5!h3ih@HEDGnSW=E#%u? zBXXeQLVIy2*G;?7A`%H5;X;irbP0L|lv+woI;~%P8BN^iHh81rZzP9;lZ!D@kd`1z za58J+t{!q-J%>^QR?3}!VIl$|Ozd2ZqSz(V+t7;~+@*}sM2svMf$^iI9BlHZu%Bh$ zaRw^4QL{GN4bqilV0PC=qd0~baTHRZ%v)t=8e#*Cm)Uic;Vvwg@5`tjQy?>96|^U>zg>{(Rj1jR^~dKAew^8yLHNyq9Dc50}N*uf}S)Txo-AlxGJ zOw8*Ak$8@VFlnnMrcki}6YE@tSN1FKVPn5bnh)B~H1lx>^2kxz~- zF^5GP<#&%MBJr(LCRZv&M+Kh-x6y;L8uW!TrTf?;bQakP=S_x#8@mIp#1IVuKY`Nn z#yDc@|K#m|;Nz^SJbpZrOd-YACzS#PQL7G`3P_4YGq%M92AF{f1gH|$3SHx}6>;sl ziFS9}T1WyNr&H=$uqsGZTv->Ex)!W1tVv6oP?k2O&;}3)|K}lsDF_Y!%J=;__db(J zTm1L?eZP4@=XvgP|D1d7x#ymH&bjBBe$!ITL}Z<1wp;()ntJSK)&JQ?3y8wRar{^~ zI@VN^>g@3B>D8CU&VS1g&9S))$X>jtvVs)hg-{>GoiST{BnApK_y($_vbB|yfmU7d zXqp4}%4zrCT&N0eo2tGg?aWnh^~Zsi{;pM8;WOyJZ(GQt=1Ya(#@lQfwy`d2yD(uG zopx|Syyt7x>E3t`{g?2lt!#Ud@pBd5sk(yB+s(jd1vA={{JtCY0aQ#C@&ZvYw(m%y z69R4AF9{A~E8BwIuv^z3IDm57ZR@VHf?L`?ObZ4^RhI*?1%=8!jeZ{iH-a|DUZ=Jn zZ=dbImkSl<++kXSGhv64sw%i>OE4)toKC*l{_Fu86n80WkP1*8>Fn)AeJnuLlo1E` zU!yks@*QCefNR4`nfx_|+%C!8W&+&*+oaarq7j|_a}E?jYTx7M&mpzNOx-e4`w~R% z3FuFd+RtgOjMV<^0?FBH;a2R8JKvZXog_Ylbd1!J@Ct{$d4c94GrzuA`7S*^240O? z^}7H}7SAL<(_QXS7@=ywsvWg%HR!ZNH~?~ zOyK#0MRWUV=2N-&<&30F>(&`RN77u%G(+>=ja)sPw#)j=Ne-=h6*}^dDUO%t{hIs$ z;?1>gQ4mLA7O{K38XF^8M5lb?7FLPknZnUCu#|}zXSks#+ThKdF^n?W+%7Pn)e*I) zj_oT(4m^LkdXhH0qXm+xXfDIut6bDD>TmJFaZ=Wr{~uvdsz(c(^-YBvt9Nq|5!t4{ zf+APD<@kyE_qaOgZc(srVw3kVi^o3G4*9g>0cy^{unM)=_I~iVjE8jWp-k-IbnHO} zg18*AuDh5&{|6q04;^IS2ig7T&p>sB8FxALdhz*UOrvB;Z z9r)_`BzdKt6 zH}C~7k69!ZpCm*0%vJ<&^D~Md4OVP_$eJIa2#wm-FX-ACSUu|j(?biNTdlXkj48!k zpQf(ws+?bqqk{#wsIG_pD@O0L(FmCv33%K*;#l>r_Aq=9#P)piYRGU@SP3gxvayyjjC}r z>O}Q5^PN;!n4=lv_3ic}Cna~o2U>0U%paKX)sq6(U*>+I{RHmvu$uK$GxTof^#CW#nPDsGIN0)^$ShZwJ+uaDKK)!uJG&Pf z({7DdVfJ>upuOuwYVLy?^6@KN2=-$2d5B809n@ zIC}%7X*VLxMad#RNLGaG$7wT@Kf7hA9ZzFUC3(ZF$?1z2S98LK&8*o}_`4}MAH8oF zPcKY>>L4-Bnv%LP+kCfWb;Kq)o(y-V#y^ZnQ+dQzo09jNNpk#ysm^at0N z8x}u77ryfYXzInYNo+L|&gB1BG?nEVPes~u^pxg&BdF_`byclr|3T*u1UbQ0RQ^Zj z!1NlZ8R|A#&wE-o0uTSGNcH&Vf;;>cAM&;rE_=eUaRlb+XL)LuSl!$>CL@2dt(l3! z;a!xA6mQO($C>9D(QX=*b}rKzUy6pPC>V0AjfYTex5f%1J*crYJsaDBCSdkSj2$Cd zO;#E@g2BfhTiPk|O@JTE@OKXKV+7X0JoZx+m_-hrGj1H^si!bP1&u!T3F@+`Y&5Vq z_#<#r|5<$LGngZ5W-ljZPH?!L%;@c!MK$lBDwSm8VI~(y#}*z5fMZ&EGj@ z6?M@c@^&JR#q0OPgBp|!8YR)mWlbW?Tb9uS)(lZ(bfQk3;si8>=flbv2-80x7aLhlGJ`Ft zVxP1)pdYE8y}rt6LdE{y-}Pdf9DDuLHO1*sZ$FFCNl z<>#;p?sLXYvmR^50ngasjfy>*@Rl>XluZnth=9lmB1K8b8&B(eFz9Tg*0NJ|8#s?w z%3h5m@qWJ3i8=r?zJH%i&~Z^8e18I*-bKQcABvr$YeGVj)}lsz_U@-g!B{ad5o_-R z@a>P$iJ;BzjxY2wg_D4x8H!}9oV%nQqI3Jqv4`k1 zcwFVCAw&M46RZiD{O#HdIdNJP5`IQArgTh$y_(58kxzv`tpU{73EfGJEb*~`+|FF2 zliN6{A$~%SZTQO%Y^bj=!O;t^e3@PNMZ{g1n~>y+6Ec*KPSk1_czO!}23@n!8ZvVm zBp2lGtk(~RXr+88Okn$Fe9|4K<#sU!7a6c{4!6HC#IL^Bi-EnIMWJpj0eD9JiZ^aJ z77d}8(=^T~Oy1yx4^OUJbgHT98d0>0nP-*Xx3)hVPQ0`EmRwVHR{G5XPB z%jpL|&XWXB138doMe)O6FZ>8#90f#e*37_r;dYCc@ z$;xea&em$2me}zt#OYR69P?wT7UfiAaRQ|`l24wE{AI50|E=Nqq*Z5_DbnneD7iL= zXFsBvyBa7l##5k!jOHmYS^Knf)t#!-90r_7P{U~_=P&RW{y@R z8c19F8$n@6Q+Q%TSbS>e4C1Qn(dtn0H5SS`a08(T1w&Zl)mx9jYX*!+|IHDpbVeqr z{?kL@a+Se_P@K_o8B{MLcse0OYVu29S1X>dQah2DsX2MgN}6eZB>d&QbfGZeejFt3 ziU?9WZkS=owafe$+Mfx(ZRm7|=&S4`-}L)1x>R*ZF33%|*4JDQe%qf7*KYx)!h{Xt zETc7x2_czb39xlqt$0>zI-2%}!uPYaN9uhq`q=9S05a3_WEHz~a7KSpheKrC3s^&2 zMAUroo=^RtCpfNXPUSp7@NaFo%~+?*_0fex{{YWjKT4#F}(3^Ft;Q?F5{UN%$WkY+e8U zD(#?3T((;x&U)qJ?;GjwruXcndtKd%Grp%k_yO24vySZR(`5(vjpcmnt@k-Y2ODVd z5P8J4Z-biVde3W(>OC71{A}_RAoys5pUGvR&2qyi6JYXT9*qJNc@tKV)7Ky zuwSZD;bU;>7<^!#qEOx{34^D_VMT4eR#zp*l&PM8J>~U2-e~nMi0ZAtIj#)Pu3oU% z2d?zzoA|*~6!RYTd3PEtx6|)phRT4ph<^@{-UX*7qkg zn}7R3#<0*f1-IXQ^`VVYX*TlRsWh3cpOETia-`ARpcQyumF5_6ZH!8jO?sJ1(*+#f zU!|F8bSh1dEV0XLHV@@0ROZ)7?=X8luA9-mftf0$ld`5;dBXQfDowwg32%Ri^ujEK z-*Km9#dOTW6gqZ_f=%AUQW#{Q+8+xyAv>_tb&D|ky0}jT2g4;QWn-yw-l%?E1RET~ zaXWKY*^Y3bD#KDiW%|>d(3&QGGOPx2%@$6_VDX)g#TOF)jZN<0w2|V;pQ5m6{%pRK z(I%S*(Nu4j46@1{CY}(R1y3)MxPaL`D3PuOdg(jtrY`K-8T5x8Obi~q}= z%9Ye3?jO#QcCj$KafMd#G5X(P;p77>C{xJDf-;-(#koKnUi>SopyB`(WDiuqu7Xu? zt}1x9DtNCdKtG@nU}we;_Fbs~={4K_G?Fg5Q2cDoLyMe3M<&L#xHHUzD_STltV9WU z&w6!>F|SO=wuqT~d2ytDC_~>lR;o>RHntNhK%LNXPuK)1>HaAIRlI(-`YUQ%FN7l= zky|P|kPh9A`jKqZc9O*eaK&|LP+mhWb@ra+CQN|;UJX`7@#BVt(H%s+&O{rvJMF1- zJNueZ@{_L=jhtH)9M`V|1vGN}8z*a!+=eHH#4yPWH}HdH!V!x)KUt1w=B{7k5|#-! zt=BZ~6(%hCNn>hg6AbYX zmb29dD_*64`!TY!-ldbU6HKMZ4%5sqSS=|6MV<6iz*?$yk%C~l#uM)P!k z#{}EA<3MTsAS?!Sm6i3=P^3YSJ^q#>MW5{Bm?Cz3=>cUm~w_3J@_tO+dRbs{vc=Bct%u^FU73}#6mLjVtSG0Z8z$9_rza+!-Q z;US;`JIOxwfUI{=Nta~3@C(V0z9On~PY+fh-S_?iP^MWS$vJ3HKVu67QGp#|2 zQ>ExMm(*oiG1YkwTQA7sV4HG7R=nxs(pq?l#|h8QN+s7xX0zE4(uI=_W!^`K&v6gM z?4aJ(q09PMswO`1iRcQld19%~W!SsfUJ$w2UO=1Owp5s6viJzPuhG+>j$g}6viNAD zdMQV|;MMr+7(%|(`t)SIrci5qZN!L2J%^agmvF+^{58gS+TLdB=e$LRk^BS@5^Z_x zj~>fCZCy<4xAn9=>=TS$VcZKJ7boly!Xp=3N4)j-$EhKcbYWb0lE`CU58Ee`q!uRL#Ygk7-O4+p zbHBZh@vz-U(p$FqYA)V(cx6RX{^T+*TaN0DN=JX0mu=t2pq97yvi%QzE;-nmORStj zwF~s_sm{SxGu9#zt-c&xnRC5mb{K2n*K9GY6wX~1H(XUx!x$dG?^fQjf86QT`Oc0# z%fo_L3sa%#YCxf>$fI^XsRlBw@m2n|*odb1)MhfP415&(jQ4#jIoNs|kYg#ZV$Dt( z>f=XZ7X^zdKgrzL{Yf2@=>BR?TX>7Kwtw2imUYw_rrenyXMK`yZSmhVWH42LG>6(d zm(g<)8t8K5Q0q*6#1$b8VR#L_;4+V;JWiz;o1m^L4%snHN_zMDbZa12+I=Nugjb2m zork@wxoAe#R&TpgN;y#zT*g2b4z z_dxP(ffYB}sOwrbaVjhn@pB4`;@E|q#o2MoXdjOlT+If?c_JajYR}F&4-u^dT0*|S zM%3nho=Cl%gyWkQD)U5&3MZZH8+jtFA=^HlNHd~+`{pt!*SR7+1fnG6W|P;b(YB-h zs1K51t0d&Eo<2s%{o-Bw2)Va4P@}xWT91%)yOX`Svz+Am546!q+@ZogE0+2l(&*u0E=(EF`1`dXnNJVyjR zG-dp9EmNRWGpC8r!kDB*pYp}XpE$ap&VJwL_#WE^({vNsMZ{Kv$10Z;zIX`nI066A zN0ojS!5FUZqgsi|RXq1oF&l=SQ+ngyg-9x<-yNBuv+n8~vHHIUp)Bw+Lq{Cn+n&Ln zg$~oNcnixj(j0tZjHOxD<(^S9HJRQKHCe&=)=(T}=bX$)@Y z4L<~F*@`RGk!F&!?)pndM6YA4yA2X%y=|nB>cx-WWbG#1>{D*X6*{O4P&J9X{dSPT z(ZcBWhmi@rEKI74A=Ek=CN*L?C~s#-AApKU3T1rHV5T)-01xFpJUG*2|DkT==5`)%_(^q-k0~j?=x(ER4_v%rzg!$jf$Z0Buj7>dvQs%%}cHkXi!RZ(OHe7q3Fn`-prU+}tRJw>_>SLtT*dsyR zA_Mw%(^zrYA4c@=9MFiqSjrn`L?0il_=>4=?p#Yf(hO5NstbrvR^cj%r{odTpGF*% z!(+N@vy+&+3d8f0t4{sOXrH=09xtbQ$*I}Xf^>C|l zj2g+qmWO!fioOzVF~R-cpBkErcTlLx{I`@nI}PW8$^FsLpl8DAfk7>^B99r{hr{=( zg2L>+ucHC_Aj{i+7WMz)3z}w_5B_ds2;Umi;xk4^9d0D;|0gisjl@t^L3-Mr{rZ75 ztK1rH{YcMr7Q%$spVkik|rqY?r$_aj+Kf|alj@EpEYACIosBJ zJ3xjUH4jdZ$~~Bo^4y;rbINQ;*g8^39bCz?nL7%zdNWvfyh|%GhlD9;xtp5Na_R7w zKgFH%E_|tjw51mqNLMCi?mWg;i%07@sWtwF*| z8)J88;GBP@ff}9Yn#rIUyzWF7aBATE`~yIny>`CqD?mWy24Cr{v`p#rcs-Cb{z^I& zip-$`ep*yd>8Q(k^}bA#QabK3pbu4czX7_Hg6UR9H7JVN8R?~r(Q}w!iZEEFS=s-n z^8Lqu z4G2Ch_aItLO(Qs#=6SZz5YfCh+?c%Y{l6n~<^-9^+@zXO;?S%&k{=>hjQHj(C&iwn zdN&=c`bOqM`wiinG`OCDW1`#KgnOB*3_g}{s2RQD4Oc$}IN=U~#)gY$Gm*L5ZhSFV zST9apC}TA7Xr02J$20Rq!Y_s4_bHPvbhFCogwrQ!&Mc$F+7B?uIgY$MTP)~N_BjkG zxcfRnW=;|Xgc(pz1yW_N5}>8fAGf=6CpU-(!gLh5M>ixEQYRBNV^1deW~Q*%2iU}Y z;oH59)dbVb(z>paB#I_#>67)A+hr%;bVH03`Ik+^?mp=_)cFdG@v8VG+fk0!apz3O z-LZ}*Vr>D7K@Arg!(p}TY78V*!!OcwA6fvEittO4HVU&h;JaHI|NW>l{{90H`qdPn z7NgD`WC(YDUlM}5C)(~xD*kRNl@rBwsYs~m`fB}@0)3myF_`5pMaQMrYt-`B)WKQ7 zHfj>V3G<8<*MWHWfxSl=p5fH$cjLwH>XUOs-`4}(#P0A^u??LG=B$b|CC;sn(Cr{4 zRS5!J{H^Cg<6MQ=>%a2HF!9>^4uFX+ibR;WTU|b|*UatTi|`{|{HGBd%3WBXy4(XA z=`!6R zWU78D_KmIdsG2&pbzX=B1-VNwgT&;0TqqqgPmIRLdCL6L~sKKov) zJ8~Kd&tGkH!K6W$p5=Hgn?9=jQg%PUGy!u6f{e@iUC8C{Z!+CVv-) zc>9_=#Ai=O*}_j4>voaSaj~EX1zvJz()@umkX(YooB(l0&h&{}3_=j~6k$2#ekC8Q zdCBpk%*J1Xb0bz-=85Mt4ZzDbDArrt_->j*s3gH1H`F{BJvDfZ6*K=k7*rY}u~UOn zs*B%r1?3Z4(Z(jtdB<`?N!y3KLoC!|RD_JZP}3V%QtF0~*rMPN3k{t9C1&&wsc63) z$Z>pOsAXC%E;t$%`%l+eZ_9fbp8kNw!Uwm%ZM8$(FAQ;G@TSpWmnk%{9Uj=Mny}97 zhqp(Ud?3PG`)3Y>tZR=NMOLt4rpUXr+}Sb9_7w1#TsRh4pQB*-4&{&hCEp&vq3g*c z?E}+uOfE-+(eU5N{4A|oP7DekU`g9Itwl)sOShOyL)$E|K^ol>g}acHXlQKW=V@}k z#Ha4Jp1SR}xHFiC8q5h*(@C3b(ZCKdmuUaLD_pzb&q7d`)kyz2IGRgFw=Oqc(D<25 zZg1nK8|Qrb{Pg9&D?(Uyy?Y*&Uj8d}+5F#gTq~8RBe6P@+mp_q0EqSxK zFC?a>^3|!_y{X*tM8D{A^%T~ejm5t`lAjG<>i$9@{e@&0oO3VVZ{&M&Q?TM>gr7{| z90mpU5Q2i^|K}(K_gpryFx?Y=N-mfrp7dWnvDU73Omnp&*tsmhfwoC)3ACV#67^qt z{R^=jUwZfp>DFDjI}-O(f9|@(dVcVpxL+~HR*UzLb_Z!VC_c@Pz7baCy2MR9r*o?k z1N?HXBc1C^bSsIg+IZ~KV_tn{vD3wW!8zP-*_l{IdI~#@4mxEMEq0@OHZd=aD6BAq zy4vbN;(<%*%H*EUO)k>)gatD(Cvc z&csU9M-J7OuDZ@fv#F3c*zSFJ!Qb`v4^HC!_z@6RZWHoFCLd3*e>!H0MvJ?k>x&<` z4?}hC_Y6rYF{QYOoQxcg9jQbd=1hyAkSGwfNamkQY3weZlhFEM&y#qb39LcqS7C+Z ztnKP<=PDmYw%C0*t#&L*)S>3zl;K+qu`vjHD}Xsm&kr2{RoTMlhwgIuYr8 zdph|h<}3o!4w(Er{x#LtkdE!*gHl}N`i-gak2Q9_7IcbQ)J`*}N^a&kOH=c7R{{N% zgO;u*m{8}hC+Gq2lgPdqch!;h!ECZE(Gqk%4bwrMm}wqa&q>pyp!AbcFIR+H_%u3R z8rG$1FW;6}D4)VRjGWR{tK5JnuByKe-V|0_++`{yx6aLrpAHvNW2EmE0_LYrq9Hw0uRVm6~n}tx&vJf@VX0olP@3tVvpE`~q$_=WK}G z;ig7xott^n)*019pT;V-Ecuw4h`q`LuwjzVV|cSImo>Am!s;*H;eIDAGRAOOqPlnq z8&%3R7$rh$7n^uSO1-5(gP(H(+vRr^0p_!xYn+y2`m)Y~%Z2r=QZ2qgw;{5XrwnMVVel^`RjX1nFC*~Vu%M&g3jY1R&LV<9!bXfK|EZp>TAuml`PjMYRjb(FBr1w0e;`JnF^B>e>tv$BZXOC^I z<0{_-&PS~cSxB)Zn_HJ?u&-RmJ?)8f{xK21V=n}Bn4+BQ_?T8*3zUP9A{4j~bfm%By2MgY zpPpuQ)lpbY>Ei4rA+Slqm)l}}TAtvt5Bfxmgyo45Dxm`Ul&;HgvX|!uRW4%E@32kC z7J3C2ZJ<}n6BSnZb&fAHTB|MVszi-7_Ey`anfwuWDz<%IH-BkGl{{qL@@Ifqrl)y& zok7pes1uOge9q)AZm_)&*(Qf*fo7CS{Wi{oSr{6&+MsDgSk@9FPoHdIR$T$RwVScZ9TT>xch`pNhu+rHc%k zn@!?*4G^eiN_{5C{5A{Yfi&hMYBRY8@%d%}> z2W`mFy&$)dLCvU!K4ty|nSCGXdDoxvE!4N~@GUmktGjM6SowAv?+x91%XqU ziCmn_b>Z8xAhsszM)9+*UIX5mhb{42Jk_^H8|(G{vC;Q6djFu_1-PJCO^Rtmw^47U z;4W729hlfeFmRHn*gFM0 zq_+_Ux$7ND1LMuEuNsuhwj}p-{74^=;;Ji_oY~l0fyZ-2Mpmz`?}|dZo?mjD`Vrl4 zBUxPRmsp$1$&z7|nS7xAX_LRQ`5UcQ+1#GuO%se%ifj0lz-Imbwtq3?T8eYD1>Hi~? zhR2ZX*V`!n9roeJ=zCoLOz&N)$M$jI`$+crGwwv7)706@8TO!Xr%w-0`_Bg}&f|+8*%bLl$5naD$2A(#(A0?g)IZtPe@LnRC+PrG6RdazFHx@s0 zXcPQQR5qjf9TEH|z8(C^TY~?&_NPnusV;}#W>m1^4~X2<&j|)!|Bs{k@8in>@uR%u z^@lf+Q&YEP%+zI0|5Q2Q6Z6u?&PmL7UnRZ->FwOG?QVkga9rl#s42lQ9MQp@+g z72>}e*1A2(x)OADDZzI=ggogwN0@xq$45iZ%NOhV=zgSZKB_>e|Ik~wn(Sr$=WW0K zi#Hp5Me@%lhsb1M`q)*8rF_|sQkIYyfq4qK0h5zo9?V@4#ma%kk5D(xGVE1ECCCG(l8T&cQ1-D-X@9hPQT+doIJy_1~4Hkk~Li>!`d`yEVqU)Yqb z1e*r5mrSFu{ff7Jz!C|R$nCrOURaEm2s^gd++=TSaL)39ee_>sqP`}Qgd7bj&X!%CM&Fsn4%?&SDb((H zMaX)%?I2;L{Z97q6K9M=J<)MTVk$zFR472n>~DLwxy1dRQx`1R*c?%O>=Eux;UQ3n6Jj}oz;t%mj zw`RC^8<)jJf!pA~U8T()HR;v*R7b(_jlHQWbrmih)0k~s{DO+4U6BiX5xr6bsla!6 zCBKey;Acd{gCM=Z>3DkG+zV18#h=CCL!gEKxf#Rh0u4-x(x_n5 zZSPbiwK#Hd64q|iyJ(|QrlR%L*;vje>L6bDCCOn(!`fB*8J!$yJ9EEjJOzxEW}KVG z;Y;Nc(@$N^8JlODP|Ws{L)fuBw1zL!m)sh3-9;WHud&~C#!c>|efrG|(Qj2}LTrwq z+Qg4#?$fU)%(Dx}P0be4)kECnscY%C=-!KLVycG4)Pps}$#3nYY3(EFG@CBIrcKZ0 zT1Y2vHmHK-W>kd~ZDK6ps3ZFsnu@jEcvfM~CVU|xk_Y$M*c0iQ?Em=QUL3l0KO`N= zhkcNA*Ncw34SLoh)t2d|#U$7HE!VZ2)?>E$IpwgM|Fa4bhM-gs5~yDCWOyD0VG+lF zv%(!NOw@;unjo`0@yCHUs;n;0sSlzq)SeB^8`;%-QR0)ZSw@tiNNBz#))ad@lN@gU zefVt&-ZndxE&NwrOAj^-ka8;bLTcJ(?jQY}a4_HI4sj1KC~@G25LmID2wO{tPS@#X zF>$O(6Dy^yx$#$JdSLoi$gPJ9Vf~CP&0sejhwy7~x=IS73Qreq#&UwCD*sXAoKx6I z+)UFVywDa^R5LBS=~g?v}JsSvS}6MPrI0Ao~!+HL-fqu?%XjZ z)l)r5myk_POR*{yn5QQdK%F6=it)XoSFd9&9QMGQG9uw}eOK|JUrL*dQju(?P>zgC zwZ#)CB!%)3Z|-#pnyoi_r2QSR>o2Y{&_!jYCfDn_XE|vr-TANM1n|F&uEdv%& z3LHkc^~xMc2g@I~@~f=8?n=y`h_35KKBtl|1uMR(2D!1-d&=#7jZr2v?dU-N?sX0H z3&lU&HflATS3Lc7KcMpf36&WYU@#nD)u+D~vzjo1{2N^PMZWOt)+*pq!$466!qp-* z53zQ%ru$~}mXVW7FEEWt!8i~5W*Y6-{7lF5v0&NRB8S|whCFG;ur!Yp8wEVdsCn9R zU=z8+PYt>QL904<)%IhsY3|#cb*R=mZDZ87J1WlfNln&iBj#pHjqj2AQS+9g2Bm-v3M=g@XDhgye-oQvHETbXK24@e- zbEqjdNZ@_>0LCq{@o{+Q$Z=l*zwv5grK-tt#RV5hJd^HtW^ZH1Q>?r5Whg0}&LxFC z_(g*DIN?cTwxkSJ%M73Q!*65q(V(z~FVTbxABWx1eO*6Xn9T7Ec~JVGh*s04kxX(E zM#tAIpZBnau(3$%^z^jd=6!hpOQ(uG9d1;y{J5)Lv)DU_-O8`jjiL|WM6oD!!qnoy zuWF>69fkIt*a`7OBF!pW3BGocJYeoFUx=6|y-(sZ)P|fiX`=zv>JZtzZ z_O#I(pzgNb99OHQmwCx2{poo=&mt4?(l(xBRk@oJ>qU7TLjx@xBsuZqNuxIfDj0KfW<#UOiG#~>c=*eZtorW&-PtU!{skb*?`<7e5W* zU%Q93uyFh@Um2x);ZVHWa9GBrtHYI)ckUWjy*!5P;=d=BdpXm_t)*B zOecBd--!2~(D$`jAVBpC|5FSRp6wp6uR>MS=iG!V7*2x?VD&5UDp>wAwmYiLvE+50 zCBqDGVaVj}H`k&}$M4|BCqZ7gFFSq=o1Rx<$~XT(Q(Zm}Fy(m~L*v9+W0)@n?j3Ge zZ7HQ!8MtvI#{^w3lLby}Uf1Hv7CYQCT0)3tllST%G@)g)g^PpCG=em}{@zk_*>9_U zU6{Her>8Eic|5z{;`n58+cVokW5EjNGvgBy1Y9gq?=8}VOZj8z9EZG~*}L=!81O~L zfKzp&9FsFR#(PtI@smsE0nRGSJ%+hhKDWMiB4eG6;j1^QWjK>VKg{59|MCZhnc`v| zHf8;6R@y#OSG5O>s!iS1rWP4SBk0s3&+sH-T_dstxth4b<66D5b<5YXU9o*L6-Sdf zxTc$ct+8z3xO>UQ`gRS=*T6DlBvqk}gh_d<7AIn5=HxbLwo&I|hfx@(b+zS{&+sItE8S90P|eBri8v>4=RwVJfeUne;TEoN zzL$75cIiPDMQ@FE7jA2qPGU)G`>?uYaK$!cV_M@uifa^iRRuq8VeOt&84Z-=j<6uY zHtu$4V}8-KZ-|J5n%t}_OYCjO;-^Fq8mW9O^dmV=#7gUW6z2OVl6*5*emhD-iQnQd zg>x|6dqm?6)9MJXG!E>iwnPIUj5>a>&RB$4#ZpxrLzC7|sQ1e=trK#TP?)8AbairY zt25eSwij#?7&FuE2INd^M^oNGs*tN_Xtw;D_a;hG|cp*4s~6j1v~6|M=u&E;xgxof7)T^ipSlso4l>7JWA*+ zC=!q8AL;NY3-2*5GMP)K#lz*7Jy+2Mqd0(>X#b z*aA<78z{i?bA;O0?w~ZjUicDz7SMtH79pFv#`y)e9++oP7To_}kWrc?rJ2LbC|^3V zt;b!SN

2t5MM%G*XR(^?CA6)?%ScCxhINpcl8^edmQS>mB}yUB4IPFBA*^p!EYu;%QNilc=-pa9TYPus(s0R!goi~`75QvVDX8FWt@r$q(4l_9W zZ7ZI8UMrZ^G+V~Tu3Yo1t2=3K7E&lCw*KdT>=Q5D1|{uO_S^mdPTtXhPcrE)4~N0HfLNIj|;trgg^B^fd0R z(RB_WayS1op_e=18k}x#5xIEa}#{WVj?_`d)M=jnxEKAV&-=7v2VDTp}Xu;G=DEt=wQ}4{-uCtf|7_u zalj^tcwV~oW+ypamY5eTKa%x6RcJzGaif8+V%>%#{C4@}dg>+f5%ZU{I%S51hXaqR z`6f75@(Y{m=l@}pdf6C(!%vBEzw*1%({>8s>IiEN$JcQgRl-sw*miDGd<)^_+8@-| zXOo-Se=0xkI?aiQi+M#;W3vj{J_OHTINnY4hpRAb?wGFuligNq?UmkQbHxs+*&tkH z9ya^#l!`a}y->O;F|2I>6?Usa4S$6msBJ_a*b8;cx}t(0VAJ794vk#K+;!g)f->%v zB<~z7kTJ5Y@vHP|j8xY__m1dwwd1Q%@Pys%1ci0uf-*~8ZOU=4-NaL2DqQV)Sc8~L z;iOZCVuYw7R@D?9IJ7a{-gR@ZwtjsSV?#Kuid0@TTFu3G{vSE%$Q!`VdeU)Mb72Ad z=k#0X20u6o2?ql7BJmd@;YH-e#Y+UT$BL)Ew;qyC_I=|RTRliqPOj_Q0P)zU>Adu_ zQD$7`N_{x#8!s5FUC+fT&K0Pd7&bOQWjjlu*U$=j4etd6nZm>w6wsK>r!Vv9%X$0` z(<(ojq~~eu`gthMyufvFSYQHLo&B@Rt zyVbwayrz?O2___u)CtxDt%s2;!!(}Hl>D--pc)}q(+-WRwtvh-04eG!^12?flwM4Swj31a<|>|C7v(Gvh1UpJzVOyjo*>HGlDsOlgs6 zeLdTHov{wXzE$ldCay+ljP3$O=>vZ@Imja6d|3G0qJGU6{y@`Gez_?5TY^~V24Y2} zyw4&ic-E<~t&Yp^g{$P9)P}ij$(e4g+M#-NZ&9I*qwv!ZxanioA!0dN z9p=WnO%21$6E_m!A#rp z#EvuFI=X|^j3>61<7lZZBVbPKHe6*s1x{U}!RY)q#;JJwGg_k=De)ILb3Fj*j~sY# zt=3mk_0>`ZjdI%8fAL?H5`C>NeVyySDkb_lLhaV}RSy!u?~^`WEmrEQ!20UnA?96S(>N=7f2&f(=fMsi?xLJ!1K?U?z6=u=xj`6T#<+m9`NBs}>K zlJHXOnd7Pxc2tdbyFE0@jUR`e_{ z$^ZCjDLkC~w(BW+F-A?i>1jHP{C4jR`bB>8nh7AsWu1KuZMX10hk+Ipt3d)e?86Bu z&XQbt9HR{#X>LR_xin=xdx>UtcpH8{B_Rzdb3sYh&>*mo)D}cjz+iNoM%+mV7T*&! z!<{w|NeDrT0H|vcHW~*vNnU+@`YS{uK|L^puV);ce_`^Q^c(`OF>URP8q?OELTr^u z!~;cXFpPL`m}Wd`+eh1XWpn7z9^c!z^eM!v0h9O7l@W?*L#wYzD3LvY&Df;Wy%pi@ z%E44FOemat3fJN|1=H3}hIo9+>rsKp9Qm%YGv@(6P zk}1S{BmfAH=M|4@7PkUZ!Y*s9EsM62DS=5At%Xj6`KE#CWRGYEh1W0P1qx>}MYb~U zruD}evRuddoC}7{9w+rcCB&pZ`Y3rqfLwQ>(+e^* zYQ6X9dXzog;(Nn87+;*D&xeJWU?CLsYi^W-w2%G`W!8+M))FTNV1cZr6HW&nbQLtM z>0vhwX*pQWuc_(8b%e(z&Shkhe^|t!17va%gl|KAaO+-hj-n17OUOZwB_B%@K^)dL zGd&IZ;S8PXO|ACYukF&6(*zIN92>f!)DJD%B7NT<(egsIDO6j(oLz@8 z9x#41;fjb#idVIYJp9nmS<4Qrh958Est_ykw>mzFe7ljCpewX4InJQE#1RE+gYRlF zYQ9bnG(6S+*6O!4ex-&SFX4>kJQU1q!qOR-6LJ40t+tlOPmA#1%8#ze0PZ9h}J*90$kIN-!Pk z_)40vZBTt2BQX2H<)w|C#m5}$~dq|)a8!c+A zjxbQ62Oz4^Z|f&1FkZbebh?QlWT7f~5lhQE4I$_v6!!#*_dECz&9daK#gE%G7dT9N zO*uJn&~>jghQFv4F7ts*41mI{3f3K&612*SGFx@e)85~Ztzu{bt+mh%yalx2zPeZ< z%zJ+G2;EnNnz;kOarEX<8p0uoa^#8hB5rpjZBt=_i3^tm7mVAc@*0jYJtuY*L}VQy zLY0lm&|y@CS{Lg;Y@2bJD?X*Gx{{k0KXa$1WO$-pDK?d6OJGD?Mo2Z9Q&_ACcUlL@ zJ4Jaxu$iw4v#x^2zaz!X5wUHjR%pIHLajuiKoGdW&= zQtQdsQ8w-%y^lIak0xIG+gL?oz7jrW<^?SnRBYI2Rb&&ZQv;>*iG_GI3fhfB92FwC z2{FX>ej_6yh-G477R$Hr^3^9PwG}HRBHBGeap^c{2QB#tJ;7BMLk22K_GItkCx;I0 ztvpw_BWjj{SFl^S!I4OvAqEFVL*}qpiQyG%Mzbgb!y;%C`jC%UvWSH~;oAHplnd9< zL}PTDfd81Ed~I$LMysInIb4*C2Z}Dijpk4X`r_3Zxjt*uX%^D0y76)g|Mx?KNp`-m z*M^Q(u4Uu`3tE9|;@cosiB6N^+nmLF>te1sg~$5(ZIjeG9t^NUfqMLP~!PnKvRlF*Jfnd6tlH}{%R3e>PKmw ze&1ebpZpzFBnps$2Z5ZR*8GfBmuks9Uq-*6YYO;JquL#=PE67V%k@$Wqc9)A>ScT?@P(Js z=(FP-$4RI?VjG@QIIhRZQ$yn=KH=Efb~ak!8m@WH=FC&+tIx7sThwUkj^x%w^|;#h z46#*~YsuC{)5Llv+#}BNwIMdJ7<&4Ko^TJt;WbEXVkxh{Qb3S$AF;C>@gny+BOO#*;}`;BfzfG?{OJbE8*$8$2;wzRnV947h?wH{WqXRa1;`K+ zM6XGUe#L{pBu?4>t}|qu!_0hPp9TsJ~36JH| z@7JSw4a)D)CP<_pK4^@BCd34U4r2l_M&+SQ>#T30*84Z>I$r@)vh|B;6f>$#xGX91 zVy|jjexBQw|4djX-aXs$YG(eH^fUswI_(ED{~-2;*n;K!rJ0ZJ72(69SHu6RWbkcK z*CNIBGFp>zJ>mz#njoNrIJ0fXa9-J6Ty=@feHF1ymC#%PgUNDd*U-g45#2Sn6Dc>^gO1TSMlig94| zkSs)v#537#!YX!THlU7b>=-3prG=Kt6j4!W*VW4QfI6l@*X$~I(&>srVT~dk;|>v_ zYKBsm$U@{{WFp>Qk^p17+-|urgT=SMM0yajNDQU>6_!_YCOOU)o>=$Lk!soWVVX$b z8S8SlP|N*hTb4W_W*D9cYEhDC!cE*n@EGe19wUYaZusgMLL=6L;5-E143$rtC3o+<6G0g7~ z=vvf0NUGUTmFg#2++lBRV-wgoM{bc*sL%F;-8OacrM2cd6LSU1m3azx+*OxN-e@qk z9SZtzS1ry4MtOW6v+d90vIzZGXxnTIb>(fVedg z;%-uT5I1Nrun`T%QNRlW;e|N6j*5=X7$(t?nu@d>c{K{Z)S+p}KK4&|5c>7h1L3O> zy{L*B{ZjidwW}%|nEgWE8}9`~B|6r#Q|>x{8b7lr6P~z}&0j@Yj~}+jGxT^gk3yYj zh85gAA$b+i@oK&yyo!7A`kc;3@j3#4ybcM!p7V(TFC^Yfi2)Orf=>%T@s}#b6|$8k zZkDrb_-~0rk7gE+K44zs)sCB@69k@!SHr0{0S@o%s+8`xo8q&OT@QPHV*6uf*}$fo z-R7>vzZZ)&&gfkijHOETwa`xj^;g<2tAmjcKURBcKa;#aSbp}wO7O-_x5Gp8$o6%@ zHpe!R+3`wxw-~fzyO=ZKd@N-+BT3V9H^HtJ4+^TGpJ)t4N}1S;?A;k|XBgxzkZ-AH zB)dKQ1`YTBx1^(y4)^SE8%2$#&}2&{9PcL3p+B+DH9S}IEQWV8&#|h;FP&B~4#_o9 zm{UpIN$mdkMZ0rz<&Mu^B@h?>k;nhdJqXhj?p9${%2qoKPZTKsdNflVl8%x()g%lef&|}<69^irm}bFy8S+LuE96ixKJ&#Ww|jrO>+|fN(+3% zLUL|1an&;*HJW5JrXA+!{aNThkSQFss6RZ~$`6{MUXi!}oFaZ=yU**q;CZ8yFbc=j zmO4@nfI$=if=FTfiH7{jY_Zn8eK&TmI94Am;K2{Gj-2r3Ok~l@>K_CO={RNnvifU2qP^1`OW4_6VTT|o6Zn@}JljE3( zoQKI`n@V?RunZ$@T- zENz}rx>hAr6DKo4krtQrLIzCXq|K!0k(&KK>rzB{fe>_;xAj>o;!-HP=cK{BHzlX z#WObvZ9Ivvnmw}WX*cL>S81TMZi3kXQm4OCl39RtJ}JU+e!L)`=il_a)Ia;JK0ag% zNNH4bF4jXH`Jm8d4LmA;3%}~M^a5mF#%rdvoLz3o%~)9)-am=+TlPSsSIIOUVHx;~ zkiaOD>(M}{qvA9MM&v~CM>YZI2{y=h;D@l_&Ril#AG%4r<%N9A$@Y@Gy^zh%uv!6t zLHz>zS|L_6Wglq1s1MK!LiDe>&WxR~+isd+*}i#^TJvm;4T}@0i!+zHs>NJXb$?WK zjUK34OhB@>s`sMuYVd5La;FeZUn)F&nj_+$b@uM2kO|L{nb{s~89EdZI=`U2lN2z(d^Ph2q1^%1(oN8QH_D$oh)@*I09@}vR8@1z_Sg}#-2|F&zVRpmu zr7-UP4Wt!j4{m0#GdWb~MUe?uK9>T&;iE==svi~&c=5kE3u)sx)6rbpp+W#YGvn1t z?)SyrJ(|eSk`3a`cBs^`XM9Ulg&n%!N@__D3yBD(V3K8l1{$qAr+JkXa0jW!wuJCP zCHe5R@D^NWi!v@UJ(7C#v+!%+A@kEY5q#le5o z@3SV_571cg1Rw}sB?yJO(eFDirt`nz+Y#RhJ5Z{@>WFHw=YjA;yqq@uDOnyCKBqtz z_r4Xri!>_|w(z8uB?U794su7ZoM6)%zuf2s;oT^4myTfl|4|BNLt{bp*wC266=;Nm zyN%<6q=2rnjU$4G+oO(Ib8ZspF^LEH1yAfCZ=fXdyX^E~%b-J*u@wfxP^Mc1DIv76 zg?*p$)sb)d-Ql{2$*y6G4l24O8}SDRXLF0xN#hp$^2|EI5#w#`_l1wMlam`?Y{czA za`%p|_0DJd5Gy^p*voI)wnB`lE%sPMw=TXr{NMnfSDq(`?#KG4LDrOb8(nCye8JNa z4iHnQ2PLi)S5tVDLqsI8NSdxA4WcB5|MD^VP>s9s3ED9xfRj{gdsFMt-_l7C5w9jI zN~A|&#ane&IJgxr4z+*>Odr3fPqF&RO-ToQe+uAIF{TTPjzGn@GfNCdDiJqee}-u| z?%b(OAjQ#C`cSWHlyJ%&UAAxL&mph4$HG^BH!a%4fGbPq_y&B5}lpSzAQ_ji=Q3%IuZF42e^(8wDNeI}J@ z7HYr*SA&LwfoxEEr2Uri)a@m_2HZ9ojM2CnBp=@d!7d#P6?dSFOYMur$f7Ju(e%8|CKfX-SOy2zXlKoRW8hd?$`&H4z-n zLE_0f;OXj-5g5N~_*OjrbYtpM;T76};X3l4US`qE__ZpJ7EFx?7ZMngP@Q$n#~Huf9?B-clIew>!C zX^Qowa+o^3i19r8S-u>R%1`)CsUp6emYc9tTV14(r;0xZiW06`BWEy3QUF1M)k3^s zvqGJu=NbxN*dQ4fBCFw*n?-Q*z#cz>bIuVq(b)Jn+m@|~Vx(pzP3}fbLnSsxq+6oz z#=xn`GjH`V{2p5d4B?$Wd=!cH#3Av`KdqUwlF5h2%sn6oZhdU7MBILbcE|n|A$%i; z_1A47pE)VKsdAZV#4DKG?@x@$xFh63OQoRX8y7zneuF}+FUu_d!Ben!GLc&UTHw znyn4~yA$B9OU$!(5DzQLGHufKJ{K=>3eWeMm-)&T`1h6meW8C}?cbOB_cgp{@}I4> zFvl67&*UD8KfXT%CpR;iEX9xmo}4^AjUT* zYV=on|acsZ$u{MIR5WOk}#6b_Ipcrze@y-dEg zDL5gq=@{{z~VCX)#UeDd+&*aYq1e7iAxk1lqmj_Uo6)ruk=K-G6`DW|< zQa!7g4~;f+lRA!mn5@nA*lf*IxMypo+C5t{E$+El!J<{BR_}D9j$h(|D_ZlrXhOlE zPoYg1t1{@Q#rK3zMQiTnQ+?*xQ>^Z(@QSAVnGGf;kiAHDzBltd-88K)%NE!eA(K|v zG9JXQ*lSbQD{Ag=-`wfeTzAymJIb0no#sxr=7t4k{_Ik71J>N>GQ&fVzjLxYD z019S<)TV5%SBj4M;-%}fJ(A9hj%e4TRY*DK3;ZDUW-+ZCu$={fra$GbRqiP?rOe9o zK{9bR0QlH+r4n@#g0N0gkDYQ~ZCN`LQytu!)Ihx&PY1WJ9DQOyN>5l>77rA4D@2v_up!ZoBh+&^yPPH5gHAG9R4Stbp8q~-UPO!71Z-mAmFtk>|;mizppQS zPua3m5vKU);dJqmjl9GEMqyftmyFt2l{)95@MUy^F77ge>+7>fdf}~nxn!l`JXkSK zVCbBG*Si@A!}}>Eycd5_!uv{jkRAZv6TmmNy$IhuK_?VP=udEtCmpt@-v-NnXesd< zln|`=w*Ma2YuLqGVCQ>81Hp=R-W@!O%e)Uf>Awb^5Bm1rPzYXwXOgAFZ%{(8qRM}d z>ot5C+o^+xu@TP^N;OX6Nj6SjA04M|pO$g4r^6?0I6A2Z%Akx`waP@_=aheU{q0g< zBE$bZ`}cR*fBzNu{}?qI{&8w_{e8cs#BWdnZXEu5T(99c-pcX+vh>IX&)@A2Px0q} z1w22dMuUgw6b_zmSxWo{B?K!v{P(zC!*<>rJn)b;q(saD9`d+eNxn(H$NH5XniSJc zLU|8^Yfsi6r5e`_$sa~Wr&C^^@Z>31hW>f5;Z1VB;p>PS={rq-x@nsTR2UbMmaAv6k zE1A&9-G2=~3_1_>aK53C!`2U-@(^ECLa^c`h*bTI>ot_qj2n*w^+Qv5Oh0ZXyYI(= z@{8ogqWf&5^gddT@n0yy0A4A`*4-CBoHOs&P)NJGLmdl{?cKc$yWSR;YEx!@r zaCA+%?A8(vUH|@EI@kgGG&-0>ONPH5ONrm0gkZ%l{P(zC!=Lb0*1-nXKP@|B`nN>c z=$`~l_0NRNGSXga1*})+E35VD*{D|yCCd1B7Gg&ke>PoLd3fJ=7j0O7cB3K}Jt%=# ztM&#x=rw$RxBdGgQW?{q|57&kBlf5MRP)=E3*C^pnad>-eW|3ojVb87)oQQ~epO|y zgWul2gAd&D7kBUjz5{Qd>UABgv6T1?N(fd|`tNbQhJV1mQ`SK@UYgQl`nOfN=wGex zUmd>~owYy`YFEtYW-DSH`k^vghfa!^(ddXx{>wXbF7+7&DmJr?*rzNdeuEN%71RCq zxL(5#s`Y3x+Uycxj_FMWSuzFg=TUrP#3$c{pD7>qz!ihioLdLZMM5%eN(bgR;jHy$ zHzLm={yJMq&*LVN1-fTxD7~LZ7IdzpKI_0?v|t@rVkz+(ln|^~;J?T98h&1_kLiFY zaZCq3MHag}X(Hp0(MhS!Dp4F8n)VD4)7rkG!76I76it_4$ehL?WneTVxjE<*n<%w3 zG`_b|F}Ty{YBjFOcw+JM;R7%43yi2{3^4z#ERKu+)E*^WU0z1Y9&w-i&%YRP7f_!e zPSJu5ai>{I{01ciD?Z`B$MqUc<4q_yL?{Tl=1Y>H(+gdvS<%2FiW{6eE|UBP7&ZI2`cw=+v%l3s&~r1 zJqs;Pb5yUgxX8-oO%rF_2yet;lOgZtZo95y^a_%@?RT9`#zucq>&C<&soAOLHZ#Rq$|TVaAj4M`3SBy9`4%_JSfPC^w<8*K!wVD)(wr zt{1~?Hg|7$mIT>y^eR;L7}^R?*^R<9l~|w}!{d2U4g58Wra?{(Eukl`(sNPY z{C(VdALJd?`oU=sw2WusBZHNdJXI|D_*oW2%(0IaTSL$oi{Z{h$4ZX&B9{7|rr3bA z+^JVg$31kL@((?u%2lDJ`-*-&puT93nP-p}&W}IB5BA+J=x)#WZh7f5{AyTh)%H*W z-(bsDUreD9GMLawN)xORp8a8|0|0bbl?0vVXze3-I+1dTgXcr!&cg1s0VT!UUX&2j z(M`-5u!~y;Dgbv)zBL%U9Z&Lko6B%J7 z{Iv#!*_Rd&?GL9SyKB*D9s^DztS0MA!4i*IhFFNDtm(EE@KKo-MwtY1FzrS|YH+xt z1HG$hWt3s8_>~`NLZKAqMQG5btkJB#8bPOO#tx#djL#rd%8QYu!nDfFTpMJL;}PK~ z!xbMLuf}z4S{f8CH6!mg(Mric?ly4z9r~v37go`}^=8`-Gwwx`9tE^HfT6 zqWmmjH_;@CNmM|{ncRj<#}nL{=GDV`-GaWw^HLB(Vx#Nu6ZNpR5y4r~l(ePoq( z3!dLijk+GghgUH#&#fQ;+sj2bvrMA6tVIr2;X;Uqs+Z!SKso4k!j85EiQYQYLP7ywv3Viq~&V-lQhgy`g+mK58)?do{};m*P;ThH)i%pzC24TgCz3 z8b{uktvFpF3g=vySe@!>e>9u`r&>>w72%WOaSWJ@Q=$^{S)x&AVY$v3vKUwu)GQe$ zUy7SBbGr$%i^IkvI#4Lirml)XYsNGL-|5ZtJXzHcT(kN8+%~$?r6 z_z=z~@J~;evJR}st0;^_@G-Fq_Nt==?@?KLt~x}g)8WaJ3G8y**6FV(P#(eYEMDHn z{hh(wQF_q^vB8t5Z!@gM#n^1$k)G)&wT<9keg+g~P3MRn_gvQ;Y+U9QxQr3X!Hpfb z2r%HnXPALdpb`zffuddqoh$fP0Htx^a6n~pZ&DT9t~Vx(T*C3eqd$6yg3Y`a?q`5O zO$U*3MEt!PB`pXg0DC0P`F=nL48mWn+(}lP_|c%?HQ`o+Z8^@E*$|%X+rq2iTusV_M00?eMQ! zxVV&0CW3VFo!49BpSHw&slC(4uj_1O`&#Rm#n(moE|YE4tvZpdMQrN34mQU+sTBR` z>#$mt%=bFdc=6wT4yEcZe412cs|REQh2m1J(~-BD74wcO)i21x_~(+?_?c|}vP6C3 zrzM=A)6XLGAl;;kznQ|4-54DAX>I{)v{2T8zn&){0Ep8XO8$artV1MA!mQ;T!?6howky*j zsFua4zyv%1ORQ)shZRvoK;wP-CEo(eCutt_zaVyt6Rl@Tv@)o1{#=FOycD!(I2)UV|^Y-j{8O%B~girfm_s zTu7SAEG0?x*QyLjEuw{DAF zw$iP;b>G*neLj!R)@|)J;a{Sn1`&vg8WnWL2qLINM0mcx>pqjjcAwAtyl7_5oO7T1 z&vjq_?(4el>*nN|hgEDD#WWR95GnJaxNMJ0p3wburPm9pmzM_gO^0>3lJ%jETJ)e^ z-#loJYI+phxmN(;*{`ir0ETD4YY%;Z0p*g54}0HPZ{mve!BU~-1WM?82z2Ek6bMFf z0nZm|sj>}J%ANZnH3uIkWv}(NZn6!Y(uh<+kKOzZ{B&#IL__*gjna~!ruC8f3axR& zme&j#wH3K&H>3auT^67w#ZN+1^{g$`Q>9WASZbw9+TFMD8M67)o*@jAXMq`)dm5L66>&vsaqs2msXEgHde_HapmY^_%-6(f#JAm1;Urc>5>PJjX4) zKg-j?8M+I15!2AW;%u`o3v|%4dNS)_V11v#S{)(L#=Jkfg~+uh1tuvC0{FcQT}pYg zx=ty4$**X;k08WQSQ0pGdUPlQyeO4BqbCCP2lQ;shz2^OQYF=SHeD?(Hj6oIwWc-~ zk0Ce2TX+5#-WqXvMn<Q6{Vb=p51|G;vSnkE!ixdrJW{V1(Li+{__Sv?#(@7>wM>SYlL-o5|O zRZDRJkHn`Y6u)=CqF1M%OxysOF_rd+h$nk4nci_@EF^V+!So~^Ar8l*5#)m9~Y1LZ#PB$8$Vy$ zm@3@*5{vVuwo`-&n#9Sstczi8d^qQ2`ZH}?i5l%~3LecKAs516=eZM6zc0qLQmXv_`3H&Hnn(TG9=;Bu9KA*CFH3~hhXDb6mVV`+ zPS;cMrr`1P_BXP+V_#4ruR)0;N;?aT$c7eA(LzTncZRhhu z0J-Zn#)u)#Ypqse^FSmrz!kvl+eU=ECq9Rw$P<0K2`MP65S*t%SJO>%x?aD==O+)oTw;Ee0y1?pkXOYj=&83N;V zmVxS5Kh-Az=;E-wpPs&1xbaLij)K&Lb`ul0{UGRvkPFS0^zsAK} zKL)GdH29aw_?1zK8pUmZ^5iaI?$e43dPZ9k7o5rxu9eI$XZWUwq@j)0^Du~!lr_de zuZ4KiLmjVhrp#kES9g3IOr5j@go+)`#oqB#g^v4*wRn0*>ARI+Dq7iy#>yf^%7sC7Z@(EE97FBTv}0J zT9AL|9n7VUc05b@xqi5O@`O2z-0S)V9LrV@f@q0gn%XdqR=f+~PBoTM@f01($~2Z8 zu@#^nY%Jcx0Q4raN$!%vjp0?Xiz5zNLMd@l7K=NXVp}C>4mppnPW{xup9GCr_Q}uAw8xIEeJx9=`Z$fCWiGO z(F%|fU)J0_Dw^OM**oQ8ZnSLTB0VxrsE@(JqSG1t9iO9G%s6+P1@>#y-fdG5)f(M* z!Mch)N$%W;vjAR*xyHmTtT z$X{|H;I-c-!428#nq!QZ11qa20Mj+QY0{H=0Ap8?ueE(KZ z0Hy#DY}dy&aGozlQ1d?gL6k6_1}ahgUo8_n6J=r%vyBAar1XFgU#AgCDQ(&1O{vs# zNW^P}<+NZzFF9oTI(o<0#s$(FN%CkcgJh?&kcwL*uGf&oE?(h}k+vRS*0=EoIT-tZ zbrer2jTcnGrL={ypw4Zw+QQkpq%i}^UR$J<0$*)`+ z+i429wvCO!?xx_CY_MN|-i^Ai@5l84&eS|L>)DIL+}4q%woSGSaJ*>mBs24la-&S| zzDbZANtyj#WRwx{$28p&MC<2!r%n3=Q*l~Z4K+Thss}YQk1&<3#;Zh#8@bhj{sOB? zd#9elTc=liqAB*KepT^t`m~y+Siw)d*YWelU?2_OLj4|*3LZP^#|9e-B<{MyR7kQ~ zjlav#^CTOOCy~lo_8CEyMZ82 z01r*pcJ`IAU=23u$2QpNBwaX~95$N7mr~~Fl4T;v_;lT4%f&8r$M8X&`lu}$!H2TA zyaSaV0$c}G*)vRV>!DG6fMy|6@Zqp%RTxkwe3%`_(~BcvqB#;igf^W{J=5{e>7b{C z4yb&7s>kcPRVJG@m!3tryT!Wx@98+Lw}JF%TqbW%i}6u$5-N|ToS8y1liX{C2~5!* z%oY?1=_0X_&Z8$f9xEOL%Oo=XKW7ZQr0Ph>GFQ}(#IAXox{ZdxNgddyyi zaZ&?TgI2J{*xyci!byTHN{Tm|+Qd#>O$44&QzQXyG|E$dPM5lg+(S+L8?ft;?e3`cdJ=>xX@B#nja8EdPD4bw8BbdQ5M<1-jI{&8tVa zn16^{_A&Dv@Af6s!S9({yxU{Cl#<08fG{y{Lzh`X*s{3rIo%xQDR5r6O>MobCSK&D zzp$80naSVhabHYScf7=zALaYnocA{e^)bZw_IaHPqY+Gh|2D0G z%b(|Kw2V&B#SZcPto3W=fcO3T;XKm8y&rVIm%Z-q@X1^E@)j-3qU7SB#$qWvNu*B4P>JXzXg_`KPpEd@g zQ`rTUUOp-gjnt>CmX>h@iDswLXUB z=FAnk%MZ9s>pl?gEx@#uVy}3eZBl^%`CfjC-=aq?JfP+ea~G(O1A6f`lddb>K+Z0B zKiI{k*FC@|V7b2A0l5%OM2)JMPn|RO-Pj^1P5%xhDA=rmfNn?y-E7=&0mTNq&PGif zFnmmyMNeDLIiJD;s4P@S{3)NeN{1hg)?rNBLGK6uW&Mzyfoj0--_ub|=*?9fr%_X7 zFLh2yGy*(e70Hj812^r}?G|Z8Q!>?71kgHuY2Eq$zgmq#jJb5o>;62S4B&PU_>U1| zko(`#efs+7C}MnCh_Ot!8Pv0S2Bm?*fcDeHW>X@@wb%JG+EdAG8b0iz^_;m;l~V0K zU;L$w%j^qO<$z>I(XUn2?yce5oqdAQf4ZZFUcKm0!lAEv*3Zp{bW`YC#DI-HOj|~N zhBHrSw#x5P5fEXZ*#3ceAGrC3j-^!by>azgOpEHhX0+ZffmmbfH>>diJ!E9h>*H}( z_b#j3xKa71qUW!Sd#>{*oIc~m`<(FDb#R14eXf!xHHNXqC~qt0;Jr-SNeUTgJ2f@X zev7ha2X6~k2zK5^w(PZ;?uQ%mmmVYJR9^0te*Vi`TYAji#vpx+efjgh7sC{FC5KzK zC#&U{3oCYIv`>$O?VQsdJY2X8)X20o62nosIny=?yf|+p8NaOGGRfP!s$6O6ILtt);bDfy&jSoWdqmgJXwEU%^ulp zYuQ_2VEJ?NpQm)3t#TC#uhbDEY>}$a0iWKQi;bmWqzvBW%)k7%vD4Pc)E6hSGkP*H z*0x!$3boChWX|?C3|=*vNiGshd+HK}A1`;C*b=fJVjLy634L)!C?FE+#bWf-h2ip( z;@P$>jpSa}2EAOEdpzD)TOh<|QYLIKA88CWVgt;@j;0CX*QXoZ?T z>h{5r!ro=-Hc0hb`oz@($(4Llb@@vSSJ4JFlgQOg>O*d8K%~ZvW?2LB=nQLp?GbP3 zg~RrG|JdU-ZcGO!3FW2f728D~mGFd6$^p($oPRB=p*)c*f z{NM$QaogWe=mAU8Oqkm-G7EQ!!zWrmtxHs#W-&2@b>cwO!c>;f1(>ob@F!`VaI|A5 z(24uO(^!DXXO>Pq>UGPPQC!0ZSS>s(-fJTgt}wu=;zs?ntG}X<$rlJ)EF<2S|0s4p zZ}lE}?B~zOf3dOqS#Py?5H?5Z0%H@OFymIEcL@%XnrDV9#lP8RN{7(-S_aao9m{7S z6%xMEG03Hp@OOd23sI(8nTXcj)b3lK7<*xm7jAh1o5}JNX(CA6Bzd7|3|HC48}Lh-1Oocxqk z1V$aVv^V2HqR{1oRy~>UAs2Q9Kkw(a&Po{2ecs!k_b8_(46d1wI81v8I_ga|qCqZJ zvHIvqjh`|r0VBgzIyn|5wA;hQ@f&@h}=-6I1uUudy`TD&etP_Ki6WWb90TwaJ?k& zSKPwC-@V*zcBZuYTeuw2li?&o4SeC%ii%ZU7|nJoU0az3%iD&noaOp=U# zy4uq7qw4V7h~SoG^4b>sK3isByf%ucaya_!#3M}e z+!&jHYxD%a4OYg=B{d>UNq;5%RrCbhS(!-)2M4tx-qbyD024_GU?U!C5l4c}O8c=q z*-#i_N%oaiG0abv7-p`mI*qub!M7;p2lpf^=}2ShEpPSz(0l7>4q29&1iQ%wBv;_@ zql%;-yiLW{#o8A#y!;?#RSn@CdMlj!K3|3lnm?E-GWcl}mpL%247TOJl-WY4GGxUb zunFts@Pjw~6tm%VNk50wrCiUs`J#?&mQZM)=G0qGYmWP=eapAy zf}H?C1EEWCo)D`ly71O$Z?`6>I)8dGfN74YY&oU>bCA0zY~P10eEPz$5_fG`G8YoY zPAv-U=;xcH{*U2*B#KF`qp%DpTI$y{ASI=xFok#pHPRs8?4nE`_@Y*+2+`D%|AMGn zfCBHEbc2XTF&~ijYFt!Tv*Tccoxm8BiFyM#9qjPVMq*DjH zRVz&h?IO|=23>|RB4Xh?kqjI-@!MtB4g3hURZ2M`mxuGYvLUQ%LUjcraJr2HU-Qb)Y-RKlg{yJNTlh^BlT z>!btgjg|SScS!SoimJYSJ#Jk^0%{V+CaGYxFS#B_79kZ36tv+apn zksOuES7MVcHX!1(Oy)|80X^~CJRyV6;K%3T9lHCFaW5X$@KDS%p1u-(I>fKBFEyjA zs6Bj(u`MCpJiy<6 zn8#4Z6EF|y(;}iw8!O7$Nt<$kM)cy^y`H>982b{_o(J9gm~#C+%in@0#HH68zC#g% z-t8}|$)6~gNeuUEO6UU{Xpn4M3WY<<7l%pPu9UAQifIz(%`x|*Ji?{vcM~b9$mHk3 zkY=2LFZ@%&kHv&+6fQYiO0|n(6al+VmRBK0SSYf;Clh;~w8Vu^SveYJ#t79=(H`I! zb%@Hy(ET4Y!W~yhUW8S~A>I$zh{UxKQ$*$TfJwqv2J48s@F)&Zk*V6|C5J>jP7ZQ& zrRu~HAThj@S0yrl!XhezH;a(DX_P@>;cFgd{dAn~2&qw{GQkVQ<1EG@Oaa0VZ=xd* zV~>7BRByymN9BGB?x6$z<|eakTYY#*yfFZ;9&j=-oIc?OU=uFs(;8+Ohw|itqQWeM z%tr`g+jl)_)jBt`9b!wouxNtT;P+Su)2Y`xcKD*75>L`BG>l_6Ozg7!g#77YMb%ku zGm#%Iilw#(cobb7-X(|VuQ19_z2dD>)P^EVkdc%N9Wh<#n(G`ytPno_v7)@K9h>wMGfNu}p86tmj8v zfD2yq>SB!C;cgOUw!mWh+LBkr6k08{TVIP8Tx+M+wakxf~QJe=}_%;H@ z7?8zMr9<}L5<9|@7^bpGj70}mf}i4mgjN`vVRg4<6y3FPC0w!-`1%JALXVBXzHESr zQ}F2=7W*Nl;p|%P2j|iQuRGC7J|L50-Rp?NH!Bj>x!xyR7aTSH<^79gh;&ot3Y{{_{$ zO!(KBlt{iCJT3B2kk|ZVi`XU{p}A0PXK~t2u>&F^r|}4yb=k0qw}!Q(fxU>y;^#e! zxfClwpVAabo%z~x%oufv^Aoe?)K7_rZY4S|ev1zW&s^BbS%FKbl=b{jPJuVthzVb5 z7FxGx8JsDsepMO{Kht^aZwJIpg~lxD=^s7F^wBPWRqw?3YhN4Jm+gC${!r#3Tjs0|k`LRrauS>M<`=)M~WGbHFm0B9=%q)TcUI@mS1!dQ`Y} z|3XW-Q31l7ucbJFOQFv30_K`W#V-l=paB7Vuu@?l0vGz4UifRtg!_zdN!i27I0Iqp zkddXD)+3-XC=3gNJlBCVvw59Gj2SSSBvoIbA+b(kQp!Q?Bb?n_b$R+K_T;cbM1^A; zFO#e`eJXgZ@S`2JQuKM$iMgvQsVg{KU3br|9G+DYhr+K0s*u@$O?(Q&rJ8U=c; zNhtm;svRvS)Yg5Dok(Zk5%^XkA}Da3Yg>Y($(ONGWRVYu1CG}NvILAWoQuP23L`Qu zJH3%(&fXxsGHe;VLmnfB7g8J;Lg`3mlf_Ssh(Tc#bjz0k+6U`Dfbm!|WpDLQz$n;V zm_O&&i_KjU&-BqH2csU|yD(@!fwrbFi-j(jRzJ?`^B+9MQzCsYkj1J|s)>e~MF~T{ zXhdj(177$QFjR^_9d>YVx<<2yE{3kC8Mic@(9cxBp7C%gB*lB*j+;f%6PA8|6IsEA%tYaO`F+3`3&+3d3mQo=wau( zaj*M%*Y?ztY}8j@8K!myr)>&@IIvsX13J)mCW zCz+c1mWV@YP~jtI;E8he^-)~{c+LCmH#JiWWwM3Mg15Oz*8q>sE%D5pCCRFe-xuq_ z;LdkX@w#Vn!7FE;K>{^c^|c!2JqD#>C6C1SIyZ8>M)}rjOVb<8ytJgSeHY7^jfE7e znBra}qOgh?UhmR4u4DOzFJZk6hE^j+WuN5 zT;6A)*|>*jFUcI>90IfC7ebV_Dn@ynUud9XFgU2NrPvly56)<6BhfX>c?@B-bW~7s zV-fqx6~vq9qU)yCTqR%uxe0J{^>jQp59fV>DK8v?gHrgtUg}1*Zf>{;yCbDyeQ&;HmI_7+S?+BI}!*XGQC>wFc z#IYrmzKo*2odp%n-c-2ffa;(3H7ekBSBm0L5y0S1`7anBNK<|}3CuwH0UlyZDeS=< z9uXNZpG{%@r@*B>hrF-Rs?`za9_*sP`}|GeU@FQ;V=@wjfwP)e{ZY18rCd&a2(G&) z*y>%vUW!TH>I39C$ChAmgp!XtPPUUex%eQ5#+Op9U)4|NpT9?<#HvDko5gz`d7|K_V5!rAEC z21Z8(6)@Ve?R{lG(!>L()b8aoVBeiR6J@E5?pqmp{L#_TIy4~xeT3pJr8u(Sx7OXM zzp<}#9?%yEKO0KPe|Q{uwGg;R&^>zsnV7|UX44Q^B~Wj`AX0$yhX@L@$z8Nycy z2ktRSg&i&67VD(08PE~7-Q%)rMLe`w%ycPF>|%*7u#AX<@TJYK zV_(hu63ysa?4nuAiE7@EY+6+K2*+9g(L1?8V?Ao$<*nk^ko&dXJzLI~&qFoKDx;wh zlJ3q{sUn~KVZqx>oium-b4pZ~nFjQ@hIG=Ud(!lE4~0T{R9EEubH+gZu2Mrmp@hE% z@lIEFEdS?zcw@|;gAnpo&twNFBU7U!MiEcvsTbtf7tWMTxh7dP{E=wgjyeD(oGX1H zXZiwCiDhN+hJB_&n9Exc54~chJb31&li0MOfB@b!M+YY`_Tp;o^5_6~)g1m^%&$G- zrw+G&GZ&UUrqGt)IB#qs)lSr*?FV3jY;t*}jO|dlNv?OE^cF>yOp!8C0l!;7@SGO8 zEsqf(5E1>Zjy=Iq;#ShJU8$q(pJT+L0F4q2H` z4GzQ|cGS3?h^&>c{*sTHBVw2@7J~lCC>dI4gvmaz1nr?Icq`H=8l-RfwIhN*TB~w) z9Ri^;>L{((lWv*4hfE{bhw@o&szu>?bFMo2@U4MJ!s#=Ta|s+=luN8K|X<2;JC4*kUU$@fklqdtGDdja$CpW9bU#{u7`A zez|1)$bcU!FbCZjf9R;=Z<(;Y9&XlGSl_CR<`f%!f~{YDYG|x|9}cwStFkep@iR&m z%Xbj)#g=t`DAFs!8Y-(|E8o+FCyLQnc^?~hH2rO|V>CxpKt)6v=Av|1c}5;{LIedrb;4UUB66X>Xf^_88}Tn_i!xzVv#C`ul(k03od?_4 zGWSZR_FyJ9*c8s7w=fc}v$4&=2-BFZ-F-;+t5!3sHs~-J@_$97TE{lkYawfSES)szIA1>Oiui?LdmK;xK%u`<C$!0Y3Os;;K;p5Wy#qe{`U1M>q02lX*C3T+3f(OyQqw!tX* z50L=jazU$DcyN2PjLFIl{Z6*8k;a9lP*IkITNd@DX%egqok!K!>>uwa2 z8-_ZUpbr!uAGKRI1utXR68>beZFmjeAa<;Bl3-kcr}FGaHHmR^O@oSx>Zp@COwH>} zv*#G$W|^0&gjy!b*jJ!aXjm2RnDwOUDSJUOb{VtMOINfh$sc5n5-xTV`Gci|O_M)i zJv#Hz8>*=u^TW)(n@;1l^TAP%Z4;Zh$@}|_5MS3XVdJ#-I%CxA0}B=dU9*sAjDzFj z4$z|oTrNO~Skq@be^fpE$18>Sc(aU=K=?+f8w;oI6GXMfb8f9v+*|z+4UCf{QW^h^ zTYh*QCRz*!yh=A@snsfu2%)#J#+pWv2_qg5&igbC=E5`2=Zp25v05|IDzETpgsHZ- zLv+nl#ST~gL&XwHk~(F&m04%euaG$iZy4Rvg*Sh1%9S_~SOMeIl`OQlE;rE46+hB= z68SiNlr;5mC(6qH^yEJo)nq$%)TM#6p@i3+NI%3o)VBo#%e-%1!8$v5TP^_!n=$%4 zKfnB6kNF@`IA8HFulT7~y{`Rood-jrFLJ0wDV@`)_S=qiypay({@DD>C-A$TALRaZ zoJ1*#GipJOxnw}@myaYc%dU6aG_|h-yE6mQ>NcK_Yc{UHq1O2>hOAF;A?@7_LADT? z4A{B*n$&jSZjrHklo2D_x&@~4lkf2>C)!{zW^Z=RGDJSfu>E8#OmGKjFpCQ{ z*!5Ho{26Sf-^ks!F8=_3wpYwy-dlM0Blv*xW$<8_ZHd{)5421?7-kH64mil5*v{HI z+xA$oUqN51oN`(Uz8a;6JPpwc679YhTv^%a$j+RVB}w?^M88`eYN{( z_GbUdn=9~A7Z_eMai?pPs!qa(0mEs+?}`I0W^<%D1rdpOjNU-(JdTs}s1Hn~5lW0} z3B$cZ%B7%d99p9hG)o)9@5HjP9f3k-mJ{X?>uV(IL~JXI`E;%2#jH-(4mQR5FA1;N zh*p5aRXv)orf~j8wFgq+oAp%c5ko)V%MzCk^o?4qUD7;_)8RNdYv_z#Wc&*ww+tQDz7*0LqqLFOprg&x&id7Q_V00_1FOAd#*NHUpb@l4Th#Czaq(v6Xxi z$o>q(qT5mgl+%aH9xj2_f<~egd}1Esn0m1bAYBe+YL7CF)cbr>@Lm)97%USRA)rV| z5Rn65vTaYvZYCJ3u4;OyY9k!bEjSCrIE|Pn)Kr>EJ?^auDL%TMFlz2HJYgbwqWeIQ zr>}QfSj&*Wc5m z=uFf!1UgDT46&r!%&?b0Rci)WCZ*Usp*$}HLGz1oLLP;N{z&fEmcsx&H|et)pDb*#o&N3=HN9T$EJ~9QWxV0A<$}j;aWtiz@yfS zvmk>}e(%q54zgQ6Y2c#?jboa;8W}IJ|Vb#tTzwDi! zj#JgggfKWC2N_r2j1s7~QD28?*JiFsz2sw@WtAwIK?Z&XmjDm#l$ zd>s*F*4j-Nmrn*s+P6$7d}BbG{t=9Zli3}OF1oPH z@Xy~5^;}hsfkE+>KAq1*(t=Gx1U;ZxkqMLAuwl2jE)ui3j&G}c8SWIf_%O}@OTD_+yMRQGwj;Mc zo!Yfxuy~5;^mv}{vA0>Jf^RxlE}Zs0wHe7)(|6(I#bM<>nP*tV;XR#w2CimBw!{m^ zPtr<`tI?%fSpLXG;K3v(Ph3=L_2@oX%f`eq}xYXV~t%&zg_n+xdAub1WTP zaxDMhp!pc+xRPFg!Untn{K)j6csm~fTNQBvKO;-M8+vgrj+<;7+sV0q5BGz2i%FdD z;2Zn_ECxM4r*4fy&l*F|G2C?P1_lCub1_Z3BR1B)6Hd3W@O@^TY1p7%iLJM}nWlVI z>Ii@m)A7QSHP!E-E2e{OG6ghvIo2CcgC7jZxnB>@#MDBN%IuWRhZeWwoZ1+t)sh^q z(%fbdlE00p*oh+YL{o4q8=M%P=kUViTJ*!Eq~7zNHdKO_`DB@b#pNckWr2=l_?GF> zSX}r+Iwd2;BBO9HUNl4%1BaeU_pofIU9Q!|Dz0hjzCkzjv(w@ z?AD*38l^f!)UI5xPr_4Rk?{;|+@WPtaDWYYV|efH837WkNC+^2z8ejPSp^Nr!v;cW zxDkyL*cs{ZZv7_~z_x6NayT|d=qGkMND87ka`8qGty=LzW}U$>y|%i_e;7etppfia z5~iv3k%9KM*Ff5@@KIV1Kgd*YJeH!;frZkMfuYnRf?mB1Bf#*l=&AG-rCZ0G&UU=n z&x!cN{-igIBK5`LjQ91RwB|M39ksdyuR*PKK+(n!Tnxn>{e?}?! zQ)>H}&1OvP(mO)@s;eTus=EUz)u?G^D-IAjDItoQ2|+YHpuiBd6;HwEU@ouX>b<1| zjo)GZX}X!7El|&-YUzb4zKc6p{EotJTz)B5>3;qbexA@U3;$e_Ty#NLInB?1-USlc z{xxACJEJ6_wZ8M&LE6~8e?`I%=dNsw?QTrH@2whi56bjlawFR=?e0eIHp*1z1V1zNC6N-h3!SXqNpzA?6g^han_vBucTUk;O1O>NKmv7x56y_t1L z_pKw%g7VS}Lx0F!F5_}gmyWsfYry@wgW8b*g=TL3O75Js+-Sbya<0~K^}(+~3xS8& z6&CRqALrON{ibgclK~lj;K{fcpAtN?!BeE{`rhk;MgF6a2q-JY$jhp=wN9ibGPtFLcv;wGpc#%iHN~on_qf=oq>Q; z1zs(D$+gZR=j_c7dB=3$~M`QG0p}~5}@Ko zfIqX;$5-KE+Vl~ens)^!MwI~T$>+oKw3SZ6TnLfw+{$u#AU&zfh!0+(F3@)^7e92<9rBn=Iju4U#{ zrl+uAwDx8;{8&u#LzY3ja5FYGAtG8~mxYy*-4hIz0>Cc621Y!{Q1mMG7QXrMJbguSNxKEN79M)s;k_hH>B;vt ziwk~$lWIlGUZ9!I6>?)I-Fw%l01k6BpRnF7<LMSlZqmOVxeJyr>w~C5Lk`Y z!|A_fY&q_&ejBVyxCTFUJ7IjfdQ-Y2+D3Du}Q7-nrg||*+x&RZ> z1*H`mLN2u=xvT@fv1?I_LbU=!UDYL$y&Cd$N@#vs654e%OSe~2I)}dAoD0v1tDoUq zBFYbDg2P%TphK1Qu`ERs*Md}&OGp%o{dyZO_FSpaD1Vmhl>?Jr<1mc5P_Sdl;A&Oj z8&5$U8Rkx08@7Ehn6dSRKwZ1+Qnq z^P$NFviYfd^t@WVf@O*iye)PVmY@42VZk)cw#HuQXhYGu#?7InYUo%BQaax_E;tx| zgKCtC6`*g9XnwU2Y*SwKBr^3T>$r3JNfc+i+WDfD#MIf8 zq9HaJ=-d(}PIc3t`Sb^bzmzW?=NMaGnIS%tQ0RM9Be=q`AlDu0q7ZAHGk7B%+nouH zzO^7{DXxbm!(JvNJd+L-~pJlxaY!D z#BJaw%fwSIcZ`McsOK#_DNNI;dWY%HApScEgx5Fp$_Y(pG_ z-oswRHyp2sxWtFNu3b0-v`+j0{d%2$;5MZDNE&_6-~$pubv<+vC2&~@w}zNp?f(kr zmC=iAuyw6C9|8<9WDCKk^Cz?TN6FLvm|R;yq@BR_xzpClLOuy5xk_#XYf6mCD78uo z9#>KFRc#Ra=M3w6F$}fRAPDx;Atd%~a}XXse@hQ=@I(b5!l~cZgUn%9wRjlAm{9zp z4SFT-@;foPz|J9c84v={l5R117Vlap(n4&d(clYnX{6Xmj)eAZIq{ZF>H*1-B14wf!!Gv)+@PdDHue(;{9r6k#y4Lz}e}%{C?wT$O;qe`I%T4-(Xw8 z#UlhbY~X!`C3e6;gmEkRojTcDr5uO)J%K7a&yB74sNmnsTe&TIJfFwew)ahCWL+de zrr?D1@AXLnh#Xy8r%NwOAhFw|t*yMq>-nu0OhH_Z;X6cygPA(T?#QkT9T#VA3OFT< z)HPc6Gez=j>c?W$b1y$i>tzcownEDQ{Bk+7_&$UHR$@2ZStbZIxJdH*V4GmTnKyNt z6n!b3+V8FTd7Qe#ij(B`i;;fhji%7wHkuz8rUsoqkyDb2@Ol4Eha925#SW%+-tr&3HTlXfO0>`1=H2#bdLr~U<{-UAX0nE0 z?%F2Y-f320U7B*BD?Vdzm0qUEc5n6F+=8Z_(2Q1vH?xPfKbPvs;krzFcW-J+ZBKja zH#Ww1ki}6NC^;E#yOoQJ!nxbh!S+kYZ#3&+vb<(V!m?JbnX(VzrJ3y^ab|xAPot;9 zv2v-0J6;a9cRn0@XJf1#kz5OwQexAsZ774>CxzQ4F{!Ru2B$SyFdBKb`(zOha z%9QV_?66qO)`l6MnVkt+sk55{jp)i!Py}WJJ_hH1#NY?{;V%e|r z09IN0<+B56wia&8)p%@?vyh>s38_zlRi$->fZ0IzN=hs$}UC^s`6jT zv6a=k{~(wh*LG&e$FIdp{T^5Km|$jcJV1K;FhTy@sPki-Iq-5>CiW)37J%FG$<#2Q zZ6&`)DZYtlwj3L>d;~UWrv8O~cwHhiHC>YnP%~>b;avn%2%yv9X|1g3#s}rU+3_+R ztWUAip#8K=8@6o@my=FVq5L+OrCWM^S$0J)7+u;3thruMGL<5mjW9b%KW)-($%N<)EHwMZ&xM`R*ES5ele&BUahTSuR*Pj#NR=n`Z zZ5EIN;5AG1puGKi#Pjbp)xFCmzbQB}>&bE4ESh0O5D5FS;U)1uhz{v-LMKrirgl&< zIWl~@bU&Op*~9aLdCUIvTUTH?>(OCoal{t>=x?ReQw?G&oeQnZn= zVrvOiY@Y`0v0w8+f!&h6D|0U?Iy-IE+|>g-Bb`cwWdN$dX61EdAQ>TYjn{RMcYmh} zBt;B5Kq^5%9U3vFj?c{fTufRhNsi=Fs!roGVib!cP*?KS@X3JRrl)qug)gIpy{V0h z;W;s0g=I<8fo-Xf?PPSE&Fy3qA48gyPq-4QB?FIUtXZ7E!eboIDm?vD&=qE33e33J|e zE+VhbKS5aH98Oj9?sw80m}dxAfIWRqMZlB=vX8TsnO(WL@NyO-m;*Vi1C0BuC%cCj z2d9wYqzhiFW%mwp7Vm>j?d03eCk>uYr*?X)rZFav5ih~Q6YO|h&V~R^k0|@BrPygi zsCf6goo4CUhqEy}DFddh(v^)ALzB~D27uLZjA_3v60Ut6tLU}D#e2Z{mlSo7BOhJC zhsQM-MiyHcvtDp=&Qkew8OZ4lG&SQvJ#5HvXhHE9cK8fdq=t(m0nf5X5NGW|jJ_xS z0khCw1&YNKWa<=%NCDxgk&b=Ef6?1fLz7SCWF-npu-d-eZ8vp~Yx;xDcJm?_rwK{w}pi3^wyop4fd0%#=ehc#QbF1zI=?- ze5Y%ZC?_EZU)&I^_e6OdD9dyfM@Rt+j(<$`J)H3gkqNCPxb;)P;H-CQN6>6=m{o2;k(*HX?ODf91cM?bWC(aG zhC5D=(&$%zf~mVG^p9hzyawrp^Jpcd6a-gd5$Izjg>`!UOf3wYmCA7kA&nuyTHC-J z&U;%KLDsP^{wnyNZDKZ)!~v-kSMdQGA5Zy+YSuuxkeu=Cj~M*1DG@_-VXWKwC9aT8 zZMo&AS`E`pskbnBiRI!#d_g4y zi~Kn?UU$DD#}={f3ARe+Tp4-umx^fXOwrfQEu0h6wy5z;=-0=ZSe=u1NXOpbr?c5G zPw-2#-eKKX_{67=pUB3Z_u08tD3(*9@#wky9kBDF#x~dPlnH(rSdc%- z&!2hkcg1iKbYNQfCi_8Z0>xG|Xw9=&<7@2R>veyNH-x=C_6@=Il`p2a{(%X`4Y|zU zf~`#dR8+IcnNuZ`7jS6FPl)x=TFx+LJ>|4iy3@+TxFGTZLW+-C$d2^Q1jQkwi}FHJsT z$C)}l5Y9V=fYQR|jka5|dH67_9x1H)Jo;}W}7p#8&9 z{AM??9W2^d|C#$Coc>cK#L-d^9xa)L`@xvDEe|0iXXj+$js*~L3`i@Ig)OAtq2Cor zN#~~6arr3a*;Wu#V`|?mSV&rdka_@zF8{pR2&aC|zRs!B7gDmH7ew!zE%Y@kfsmV2 z$5qZS^CLK_ktJ;+V-|?S-7AVZuBXx$KP|R_lxg1+FI+=$%|SZ<1$@hj3ON!SWIx6O zN$emKyr#ZX2U{|)faI00#LXehYfy0OiN&@?vKS2`GJ=qE)GSHi@*~RgH$Xwmin0m} zacSTvt-ReLlEus*18Tkst4Aj6valtyY%k)jWWC25v{W z3+bFtg(>S1290nHq?uwaBjsIpeIZprW(0Y{wuZr0WGN~O6g z1t{fH>#84d1ES8cy*V9zd!iO;1#T(G4ufqvU>&xE)1rC^9-a$+5x7YV^cl4lYg(NP z-jg^GJ}}ga@P`q|H(}GmT2{vynASI;@ymc^a)lQ&E*REyby26+6W6_0( zpf7Cme?0m|}~6IvSsY@nDCT>UDp?G(|wd(8xR(0a#;)`MBsY5iF!nC(-aXo;BYk zp}8|j*cn45)q=j)LGqo)zpZZ|6(l%8vwo)k7QB8Objp~1pk?ibE@5k=#^ zxR5P9vEYmvb; z!&}AAvpmqGeDf1c^s?XT4>-fNHnN31Gr%UTfn1jL|U$F|ekrtCeE#)>@{W$u$ z7LmFk8K%i#iT(6nA_w`Y4rFjtal|<+?1kaD#j7dqw#~nty=w$)7EFZU6=S0?{A#4| zdoqVW+1=0Hx@$ZfL^;kDdJAm@yQCsDqA^8{N@fXx*iTVZMsl~GA~||)Rm)};Se9Qx zImY+eX-$|0QwQ5WC0et7w~-j$<=aqA@N?zcXu)#DRG&8@T94M(wDq7XvC8-+MJaA^ zm_0Ijx!eGFA?}AVEaeV{iBYm=|My=+=pR8%69hj8;P^H{bzxZHOtQz)GtuQZju=c! zDhu_XCwLocW%mjftkI*14wuDQjmv1hR)BIszH_9^yX`Vw+AiDK2zNSDOlWu)%u42zWCp^9@%D@%lM^gsT*l_o{9Sr^s?r~z=mTN8X#PN(0q)^h2#U*~EsU(Ro z-CD^-)Vow!(p%L%nJy81@n0sUVWX;^ofcX>s!9-9k`5W+LzdyU<5Y|GLlACV?sflGpulAW`blCmFf=mVs(5{IkmVCmHPyGURM*4_V?O@ha37 zpZON>ld|MAbVjG~Cj2=wk}Li|{kVW>1pDd&Y)#0YYS9Kid0s#MbDepODXdM&i| zjLp?rmsabJugf+!0I<4T+jFXlN!Z#XNU~tUW3fX4KFvNARvXIdKn!e3_403_ z-c`;a2v|WuVFl?AU$b~*IhC5N3X+sEtFm5!e%LxWkuW!6Rv%4*DqU1)ej0=hhOHzo zrE6J=9q~zjOXe3R>B7qud6bRqmK{i%ULF0S7i=SvCT*_WmkM#}F+IUTYcUE62f)&$ z`BSWJ4Ey$qMpCQzcXfeH4X3IO$Vl}tihknQ3J(oR@l!015W&VHhGIR}B<2+S1QT4N zJ+}n?kK>Mdqk)a|wtjz|qylF1Rj=!f$|X&OaTXzw3-58;E5gszPM4Fev_I8l>}FPr zE=Lp*i1oOi=5Lu$s3r*20y9Sq<6e+|Ek)tOaFS0+V&CeGHN zzP9-Jv+~oD=znMf#m^lyJ<8yr0oy>el-8&<;NK!`iys2vOH{yc46TErA1=cUg(@FB zCt*vBN_ggt7)ntVY<+2Zg7P_rljm|<+w+$S5W%amS6!;GN-@VsTQDtw>w^?ARiPK< zp!i3sLS@&Os$l8&N~!|s_wp#@T3Mhk6nmAkjp2*}pCx0$c4}Uetf7D*)woF%sRN*T z^oSq+IqFcCX|^_hPVd3!CanQX1@fEa*~91TS20DiHx~}D{S~tQBe0hxSM(cls4*Hp zkguUofe}Zb#OJi?aNJ(iT^B+VffrC#(2+6xFuq2>>x^cpYn9o(%CsA%_`cgUKy+!H5fKOPYBxVKr&< zK8dYMW3fep-h#?l%U;KvnOTKh3#Q#gqLR7~s#JIZY~2~_slb|}Z!38OhOyRk5pLh;&j$Dcb~2jaie^FNMEwxIGhvr=u25RVhA$GI4bKN?C>kJLwR{hC z%0DRX)SQXA2nv%Xk=z90Qb{yzIZ|e6yk6Ij%Bh^T@8uVo%{7=vfn~Km@Mb0i1_uG8 zH=&`p`-X11od?rzJzbhF>AzTT?yllGEZ@eLc>h7`@Ht!fiBdEO`l1&(Fa;2_6UCz-dA6q(ls-FH3mJIaFxZUgN}%n zhs-0{6fW3|2H$}ATc1Q{p>VVdkpA`X@{!#Sni>_B|4uLp?sIWk!46jb?Age0Ll~0_ zo})%h_Avfo^E)t)sQz?TcYQfA*^B;$_F8ssi4&$;ABid%+&54Jj@dv>+JHWR2^7^V z!!{2yXEwe>;{ugZ>TYG7x3RDX*h|kx)?gYz+Pcgo%&c>U2u#+quso)hImp`|IVhYG zzVy(b*WDtDK?zbfcb&g@ z5*u7}(CA*hC$^)P9vcbpLM9eGevr17cE3ZUO%Hjv8oZxuO?Msix?&84(1*p|nj^fS z)TV5yXh4ClL2npHTj&5k*m7IBzme!GC2yPcq#qpLen9DqM)eKF<5W(eCFZhqryX*{ z$P{Ohs5})1yaF%Ch^QNV+oS!kQXtmtYebe=aRik7*cm$IR7tX zs#)+hE(T!G3Jl=VTcf2}e|FS+r{$`hx;z0Mq0}@4os-Ys%@Em3QL>l^VY9GW^T#xa z;S|?fECt4LJrLBIf&ut1BbooUr6BT;umf$YuuR8Y$er6FO53RQ%!H;`A$91MCk3+M zZaKlWO5;ZYZJ;LoV_p^{7Zv|NLTWU`Vg+hMX(1yi&bmN+K^wfqyZN8EMQ?TOTNHy$ zW9Vnm{h)43@i6wzTUhDOoO7z>xv+RZdGLlzlDBUWfCerM=YJ7RBDWKCJyh86bK}c; z8**Xbx=IyR5T8pE#fRvVx>18{4vv$g3bW=~*3W>Tykm;-`39MY8{z~GbNcY!;@jwW zY^_k&Q&lWC$mB3?0L8oc9gQnBBk6@-jdUm1xH$f3AH3DgIMj;oGe2W|vSm!0+_%rF z)=cp~f(S;gP_ml|B9K%lev;{vJ%-usp}_x9J(28^0#dw%_LyJomm#@+lnnQ6+cHB7 z^4Cp2_%*l?i<5dm;63|c;fZ3dh_5<&4@bs!^sLvthYOLoHk^q^FX}7*6>sQY--I%I z2qNb_JzJbd46-WApN_8lJlb-5usgMhlbll9y^G%^{N|G5-6xiHh#hH9VE)|h6DvOD zhhY;7jHqSmTY76thVB6s1 zfw7Fl510|HF*q(hVk=^8KJr;ao2kZeqHNn{OGGT4&LUN?IjPgt41>9F4zJ-$z)w;~ zdR@2Eqt2s~ysnS)yz^*T$H(Z`IoEwvG`MXHbMC&6vM?1iFZFD1VZ1 z1v_OgU;SZ0t@8lpswv#GV3XM#dOPDZY>*v4oW)iwJ0#_%xcAddp1&gk&G0XydFJtc zT&aJfY{i!Erp~ez-ytXqI@%h+lD1mwQK6W2Dri(%3$SSN2T+&Gl4JAF9DkSmDrTR4 zwQ%uPbIj?KmaV1zPDd+@^=k%qK=f`GypC;R`Q5#o*0;3j(r5$YOe!#(b3wl9!R%RO(?hw#QsB8<*1brzT4k zj+|ahI5}*|;^fAh3-+^A9*UR7Od@a@)vSv_bPgT-R|{4J!JjDnl3_~SYl^*+OYL`g zaO-4>78d66Gzhzo=c}+vx1W+C+1aXZqOPbpu@^^E>gQDY$)ZYKWL^*`M3_cyXmt^n z+jP3^2m1&M6Jt=1K$hjn7CxPn!*8QV4m40A94?^%5e^`gTdx=@-oZ`H>*55x_C#u;ECXBbjI0LYFDL`x6s8B5S0>y?pV%L-Pl@0PTDDlD+D* zj{%pE-xL7Dm#Ci!huSVUTeP=KX<`^@T{d_FoKQx^ouZu$R3hOh?G^!joX#)7-=%@B zFjEDh!kG`N6I6Aop;ct@)a}yUMoui z6qPUZQwEB{LIXG}l6+95mshri#?*oK1>C@COQ(jYsS4P=#5HFew-)*4^xuuomGe3V z;Q5>sS@Ry>htu8#Aodl5{JndvcjfbppHW>2BSFonE}lWvPHx!7civ)K2g{V|h)^3a z<>0Y)o0x=7Rhiy>h_I0+Oi!SBSWhIO!DkqM?H!Ed0gLh^*Oc3Gd?z!*4~ zK>=q~Y-+PDz|IUX{2}BH5U~zui>EBV5tQ#tZl)5&o34}j(Yv3iMx+QWVT9T*R7F%N z7CMX^MRtuK47mp@xznUZ;g+ScioR=`<6dDHL+VmE?^^on2;!h_bZ*9wM5LUqtqJv^ z4xNtwsBUqo0adLg3ZJA}YTLsL&OW6pO&Ks*qx>_*fF%N|0P^6;k|wL71aa-!qw%WN z+RZ78mcR;rL{5n2HCbmwCxLxwVJg&Xrzi$gB&EI z2HFs@Fn>DWShhx7h3LGCyeM#hzZDX@sys(9-(w0rfS9y(_iX#f% zi~?Jl;)S1UIvssdO#A6XJgDk!qNu4XNiJ_ARbiQ(f>{H2C9XIVhfZMmN9es-xRR=D zA{eam?ZAxsz3-n5YN_I=8SGoD|D0Q{R&bU8ixC*Xe^+~{8%W$-xv2G=tbJAV7WxSe zD(;Xrr)kqHR^@{C&B!F0EWKIkJN#r>)N3kx57il4^VY(XAZ><@NpEMYTvOR-CF-iY z`*gBdzVe@Q?PM~>imVIP&jf_|fZ=gPP~vLJ1&<-C!GNF8hLk7a`|zor>>MAg9ZVC7 z0b85QH`oNtQoD9LyEL(X3BI^jHiL7Dkz2=IvyKmNevx_F8p*`}@0P!x4uHS$2)%@xkbAqE3ReRug27=oS3w!@ zdB}xFh3Ak90=6(DURUQ%8@qO`nxZ@!AsR&nUeTkpyt z8={`$_!r-=%YPht7R9B5XOz}Gh5E)$4;bMk1Dd^+EXgb>V-9uzNRf_R=8jOeb3tYD zLXy7gTF!uk+5#pmd}qbSaPz^^*igV$>)BH-4$D|C0cajKh0_QHhO=<31BFMZB1-_L zau@AZusAYx_WN<}lE;x#As>pIMlc_HuQd4j^6JCOL=v<|0 zU>(KT#*e^yz$}4uWT*O@tvwvxK*>kcqakjPlY`XWyD7#bK~vH0SR7t>?bO8@Zqq)z!iX@EmZU6x zwNIe!a8%U-+}VTT%o?WHo^WFLqvO`4xc0Wj@=DR(LlJORNw2l76uv8^{vlo{ya$hA zQ1nkzB`JWQ5P&oY(t87s0LMG2CHO|2!No;)xryd6g>KWxQl2MmH ztN#17Alw^Ft=d#)H3{PJf;Yw*`NbA-Sy)1MB94U?rUiMwpnJu8t}fMy59h}QY;{^m zAA~_0Xhd4R8Uv?U;c5ca8iT`#j}5Fx^)Cn@z&vLqGKPBI(^SyMD!v5Z)M3y_K=4-0 zfg}KM+g4F;jVQBOs{*OZ|M0 z*#qeNz1#qKGQSrM`;=IzZ|+p9(-9B9*d|^OT4#cA!K=_ z1D70%1YV?i9&b}C9CRDf={#+By)M}j4ZxUX>Ug+e$e~NNlmxbvIMcXnB&hCnI<*bsZ( z?2~(0cNl46H(uOc5KtniPSXsO9C6KS3$RuQ6?3L zuQjlex+Z4&cLRR z$r9q@$6iF5Vcu8)*(-Pf#$`Vl3InO^b3}r>~*r7{2{H-sl382;t3eeV`)lIWZI=Jau&7d@%k>LLu>UvV&t5ezrMTXP353!adSQ$ z*vu|2l_T$!A8Kqm;$`Z9z_EL;aHkAp6Z-!31N9`GC+E9UGF0Xn^JEZDFaQju%=CsZ z+)pe)qi43Qn$sir9yV-}DbE8EQQ~@0WEn*-f53<{vFaL{O>`1upRHhZL(448cbp273VX0GPe&sODOD( zSin->Bm_n47*O`S%LPG$3C!vzLP#ShV|#@yms?p)1x7euU8}E+0ZR%YohzrFn%^0* zrF_d0U*Vc72qW%m3Kv45l56azK4l@wRkIcL)mo>Inp#5)nc>3KMmJQ!`Cfrc)qD*3 zV>|8CeoHUd{Gwk7f2-fgk#>Rk!0LGM+~l(ySPaFsnZ@D~vbP4=_;G6Ap%76Q7-gP{ z^SKOCxKwN6(|hF?b2DiKf6_-XC(U5b2yNM!^5kq=yMfD^${n?3L6aq%q@f6%{kb@rb|H1(LG*|o>Qfz3u8e>vGD$A4P1 zv^5H&kz(c1JU{x-l<-4Prw;hE@wccK0p%tesUX(UlV1_=Ta~{AEMfi7n7o0VavBh; zW=T|6KzvL!s1>L-+^B`*&~{^o-&TMnAD~pMHTj-7C=UWqSd7=TdmONMYZ|v*6%s#2 z^~rW(lv3wD>bcEq^gLl!zR7D9lhc~FlHaB~#@jAQIwH2XNHlSqa1lP8DzcR0a%Mkq zFxK0eGEqGAtrJbyY%{*DFh%#h?WbE-gK{(O&?DAQC`zTPd}*_}Ie^VC z3m0wwU$w;&OV1B;Q+_!;O%xqEiH-9>;=zL_yT`VTJvz2K@%wj9_6d$b`@x&V{?l0F z5l!euG?W{{m1rN&hwF$;A8Axe2`|)yF+WZS#q)|eL%ZT^x<%Ma4*CR5`~(W_Dvlk9 z53Z{Zx#5esJs5H#Ey0>s+e7F~|0Hn{t*Vl3>ky#D0B4=tw2O zSbcF}f@96j{okdG$SqM)d59I#L3G8nJW{cPI$_nthCs);#lE+SeS3m#5eJ6rt19@O zMLz*XYEE$8zv|TxZZ`)P?JlX@9*Ut=rhg)e-OCNF#YAG|o3Jpe#W-T5j@J9S0*9;j z^{cr0mwoo^)lZTP$iuHaVxt=rHiqc6MiOdd@cT@^buQH%XZp-^F_?z8GJ-tgyH9YzOVw-9 z%AL>V@j1gAks4l){I=r*U9}QZ@Qs6PB3HlJug2;>U}_fV`jUSM6B;=Z6cR#9Adz#xY6H&b3^FMdbgRsXbKp^aXlpLvBoV*23JEkMiZSMZ-+!MnYJ zuhJVaqv@v>T;&xk^$ITdhb{QAQw#3%3Vz%x_>5Ph+<5vmz3go}koOnZng*U)(-*x0 zdnllhe$lJxFQ?Yje!$lB6b0dO^$ehP1%>p{E-C?(y~4`y507=ov&XEw1`}jB*eq-Z zwlF-cm}bka!s-PxD-|w#%doU<@ey@x3ofdwH$x%0X)v&H@pL{#RqbAdGKW*=N^WVr zdlg@xKv~Pkv$(8sGx<~W6|OA0NrdPxzBTGWA3B}05^PD3lx!bP#D6ms=uTe4XNd=d zh{bT1MV^6TeqeB{(U~?9cb#Vmqfn7_!q*wk} zL*a|e+;uWpqDz-$e*sj(N*T?c?|kcS;K9pFkC}{qY--S$!WUfcmR*&pKATtuZuUb^ z1(uw4xQBJRNL=^xR7)#O4`L1Rk=X5~ZBQDW->Bcvcvy-WTe>%*iy@xmE?cCPNhACFhiC3?H`ar3W9f)sca;zSqcpmMiraAjfgO`|bA$v-_BA8`)Ivh0kG_L~?Hzw&xt;LZREuf+n!X&fv0l$3`Bb=1A? zU^Kuc^37eW+UxN~bsk|2-C8xj=GcI$uh_Xi6mf6L-HLm*e|n~rOu}ukB3N(b0xG8b zT5%V>rGW#BC~6zX_j(8|-<>faa0va9PH@~tSj2t|D}UuFp)Qtvw_GPlG9Z~|`e`w> zCP_F^A@o2@EZA~bCZyt{WNm>@=u4|3-g2$Jo`T2thU#Q;H6ZE3QA~Ufql)wd*Jk+I zc)(AvKx75+u+9)GDTP(%%AbzO=}Yql?$Z9GX-8r^BC(A|o)|V0<$QeQgt7G{gdudo z*x26>E2too5vd#-t~-j-vks{F#5 zyNkR2N(CqltOF@M8$U`}!^99$>v|c4{HR^{!~;}#EP0mz^(=m{-_OYxz@X(6?u;j~ z(#}eBIq?^{*INDx4277b5Ivd@iLv$J;O#Re@yMOLfVfcu z<*T#5j&X+a3*xy>?a!z-(6QuFnx`M(%BGHUn0IY4;gB0>T%08mO{7|=rX>U3!of2jZ_$O%5BEYhjgCRNAJ*0O$Y;TKsv>CYf6|(&JU%g(oUf_d8ye76*iW*VgUjH zO1I{%d7q$}F$Ms_Z0-EpYwt8>AxbhXqD1gUHhvLc!5K`ZnYab469h*CPhL$(P5}mX zyusKj$v<)v-)C*HVBd+8P6OZsND%=g2T%$ac0_ zzH^6}+E85)XEb)mJwadl2Sc6a0YrvBxE_e57zA)L zK20Y}@sAUKa3`1V<9kf$VZh(YPG5Aq;X$YBLGiQVxoePKwg zDun_%f$qKXI#N~<+)g3#J3$L`803lW!%JPkMfJ^Eh|j1Muw6|tbWS27pytq zBO{fF%A0@~nfWZ}ljry9O>uC$58gDS@a9m6BvF+O{aKn~cUT-6-rgUFblye{2?l-9 z2#DD^NZ%!NDl+)wV@=$PPXC~Ng!AO*nRVg$6I78xpdO3@lW<|RvR47MK+8}eQ{RJ0 zpitBuel>6@L@T>Fd(A6!sIrYM$9n3+C;}>_5X8ee##ROnGf76T@W9=JPQ;NM4oBjY zHSF8t!Sk|$Gy5XeUizHko*sIoQ0i1v`e>bm*DN>>^IX&qm5SpR#Lrbf1gajqA`+)! zuv)Bwcb)BFmh+?(eb}?USjiV*pL~aVu`BtAnciAn8Pm>ug`ZBOpw|ZthQY86wI?q_ zh$`VOgg z8x~Hg{tR_28Lt=_ZVvfPZAb&ozZ9BvO~<*t6JR%i7O}1XXs8JXI44F2B`Sjqt9nDn zJAFDx{&90YXonFV!5bs&khtID-yn-*&D&T|kzR@1xz;v88v~ou z^EIr6BddplW4Rw#2h`Q$#}ltkGgU>L;_dNsSxKbV9bGbnh~3VUn;|up{1ZF(61|$m ze&tbClN;sHA+uW%{XS&Q=3z2(Y9EDb&}guWfxTH&+g+s;sOd71tfdbk6i!m#o}X@l zei_wkG3d$T^cbhM@oA}Goq!s19mF1qy*Y0PuD4QabZ^~_@SugaWM3_A;7-1U=r*O` zsFcX1w2)YFpCLFBTqFpZ0pG}24y>r*T}m3qRmHbMP#Jo2#V+96WM4*Qgzl}zo5=kh z->^zO1z_H~$qb^(8w9SSM-#t-+86+QPh(y20Ar%bZ_#8V_Qt#{ZxFigH;B7=z#tyq zbIKsrGZeT6E;FxEy9Uv`+YDlise!dj{TT;Agj{bBH$Z@=83cM-I*^j#t#%C1PR{Ai zAc8mJCZi*1J4F2K%!6;?7t_*U12u2M>+BJC?L>$}NQuj|icKsl-{4T3JWgsr%TPc6 za`lZ-BG5$(P-R&BB)<7YBC3KcY35rw!n)(Pzl`WyoA^Ahh=4-s$7pfktav*v+t!tPZW{7mI>(MNq-WQN9<(qbq+ zCXu*J@TmSlv&@3l6w%`s(>xI7+r3Id3cFSL(Ufh?QEv&(mgwMP;9TB^vP2iXZP8FS zNGO-Udrd=5-BncCJP^QJyIsf6d-+52z+UU#3h@PWPq9+NNQ&!@hMZ{!LxE2(`nX;Q ztdPz0#=zjkA8Q`S##;BPvv`)2DaY!;%>xM**1c-5o=)Ufd>}Jl_Zh~+hqc%6M80Ku zBdPF7uDExG27A#KCDP5T@Pt&KBnEViR&PeQSL2!vf6+a73f?tfQ^PvCOa zPAKj$+i>0bh!f`0%>_4)mI%%sovo41t<+REgPMr2pzyyuPe2H69SH5#Q;-6$;dcI)Q+M9ODPDuqo6D`F-v;%!}*Wt z#=U~F%6|y>9yAX|Z41{Nz=`|iP^?3zLRd}Y>JSZ{Q6WA6Z>ab`p}_bUSp|yI3h_au zf5a@qi`$R?2%103KLN$iWu_J!C28|~I0cGGyo;9B;yltkNl}$ZT*3;2I;5?!crDW6 zHLOpI)3lf^74Ztlb$2ru};FTyG5&^9&RPKxRy_2YLX=VT%s{Fty$d748hiPJ+Fz@(CnA0ri=AN4!@yco9LG zo2bBUC>Ucx=dR>I7>p^G%6I4S#~8tr;(oz8Q}XQF&>3k*N@5!&7#46xkZ){JhV2;^ z(F0$1{0pEy&_SFVE@>ENJ@}*3x*QJTSG00WV&ZJ3sPc&USjXnNe5SJV>c_rR(@xa0 zGGn9*A1SFjx-67`4Mw~pGLHE@GhQC-=u#R=9J!VHaP5#F=!A^>F|2QxuDp`iOd+k8 zGW)%qu+7Sk+3YhUeoGP6Q8`3KQ{rK{MH+TrSuu#t7zEj|mXLinzXdV~wXdYY9<1f3|Lyq zjs&?N-#Do(BC9Uhy+uk3f1e~e8bJU(~ ziiV0+u?9NCwpgJ1A+$L5Of8;vgp>NTXon`uU!w7r<%iHDznPjV9h+w-9DJ~I8bPPT zt!#kVh9bIF6H7UmzT|}ryhNFmT*b27ps35trt)u6L`3rvIGw_BQNd%tNdZ}e#(gQLIZO&eopKbyj4O+ZOK*J#6x8)*$rDga2Pk6;W2K3$WOSyavnTw ziyEd`^`*v)A4r#EJg+#ri za^M4`vMzBRoyhfXXd7*YxFi6s>q`F!$CJm`ZKOSMmMCc;>JwwgUfI{kCA>B|W&hA=YJ zsnd1ow9?7{VePGCA=5(`zoG#%eoGj0Y_s>O*&!c77%7^7DJb{#WPR6Xyenh9xtSpZW9y7PNx^?OlZAfv8WKcKQHi;* z04euu#f{1@4s=!%5=^Zk0}4DrawRo*1TuW)MvA-HRa}gwc8j^6{AJyr4mZU@(VTSY z6%tiur{D~l+V{?-1(-I%PK`=W+mGD=s(hP^p@jGJ<8-Z^mJ$YiSZm)OYFncz8hS(( zOHcbZ+u~B)OHY&K!92j{+_>L9_UaWpF`5sG;)6&n>4baaUGcEmWHw%>hs~G6#G*ad- ziM~>%mx%f=Wn4=2B_g|&`6UoE=J{Ug=^+m2(ohj!;ewC0abbWC8e$UG=LIh_0H?>B(X)hUmVnAOAAZeec6s8|hceo?cc+y?w;bTg|4~G`03W5kLB_&uEAC zX}>QC&ah$1!iEe(g}V$TPLlp#+0us?Edhe(ed)3vA$qzQRvrk!Bg+&G_90HlB+nyC z_8W{h{)w|S!qd`Yj_9%R|4xrz!9PE7$8<|}KO9JVOuR6;SGnV`Mz8UpIWfaHt^apR zpv&d7{sH5`R52Kg1mayX9sn9<53=fGM6g8ehPJ_;IKgUCmei|5&>KSP&+FLSIFtQg zE&Sty_JjZ6lay5Y^IB?hv-fflyB^mtdqHupiv0kZVBUb-8=j?@UwmZp2yqx`oOVru ziv70f@pEa49^7nNoHvBp`_3Y_EF09Ocj?mu5t-VIy0!TatL+!cs0uwGnX8bGvOgp{ z-xi=xRW~o7vBcBYTe|&)iLlt8ZWU*zAKgCmn(F!Q)XhqAtMsE=Gx2}R7D(jZ#ldA! ztPz`%Aw60qE@&R*Ug!uOoI{ngoPeOzQF@tT@eVbbC)-)5nc>(Z!j+}slbg8Y=AbjD zoUOjuH4VUEK}O%aqF3J>BYl&NLn9CW+Sp6kyBahL+37qo2#_%MlaF!v*YQ4mu?Bhu z%04fPmj>y2^v#8)k@1Vvi0C?grq=pmM2{WvM~gnBwJb4zTC;S0r79L(zgN#=cl=qp z7hRusrWQ}jx$^t8*jL!y29ovan>TUSN5uU<(>E^^>pH!B8zuSH^naIcakI!em3sF4 z9qL&Sw$wA%6!`%4d_dW3PTcg0NGK)x&ZKPS?LCErj9KR)kvVd1Oi)Jzp?GM!N83cS zNy&_ROE>qzjdakEk5M*>jRZ}i$N$bq&W^KJrld6L8KxpO@*y4Q#>-fLI#rX{*oj}j zFQNk{<%cFhRn^a_?tbKS2d$1A}?lpY*!_st%4HtbU2~{AcRmX-V&b4{PoBGIG(H z1Woo|XvYA>8a?i@&93C~f3ybPN)>&_zo2*geMxgYYZq*RDLwQ>qlZ4lLrbCfgP29( z{}VlQbc#P)ee|vjf&8@kC|QY|S;|Lb)`#SA|6i^TUm`NH3D1Nq-?ExLZV7rL?H|;P z2o-H&Ql|dR=gb_qli%V8@>Lv963$$G4KvsuRt|_h@|L@H6~gmTSA0!8nLn$9r;@vO zqPG?{swt)$DNp-lvZRl%p$)L?POnYdi8Bd%F$vLw0??4e#Os8bRcA^+Aolk}z2<8O zaBTMYlfOj2vcImB)?osUx#N#K+ZQDC60_S7K=p*WCC$UaAZ2$aX5yKlAVE4irRb#W z)$@Dp)v?ZA_)JQ5@cXRHPYa(4dd7yq8MGhcbR?!Qn`MyHw~=Odz`zKzL0=%jN(7{^ z&7RQtL16t6E@tNHM+PuqH)?f3Cd|$j@OXgUFllT4%XBKG2C5hAsmt-SZ!ZkYyj}=l zOs_nSX1n1|uB9ertdj$>cj-Z%i&Gui^N%wC=UVk6%c!G$xzPvOB6(_GP*~PUf9KK- zyPsk~qihkUfy|GldXRY&0WRiss+K(dFRLVava1bTsG|pG=!(E_dV1ld$fak%qt(u7 zHRM$yAEO}y{cCAVB!q$v5t!D_gdZLxxb&gc50J^z5pR62LM9rYH}lkPRq@Gto-yP5 zAuSuJ)x`bjRsovg-ZoD+sZ-U~X~%fGU4n@C-0`>5K>snGahiME`>-*#p_Lfy{tuLT z%K)+nd1in88DABer%B5o(@Gmp6cF>mJxkWXoTq8nSt;>V2U5c36Otyr+<)7F1yx)UKpd5 z#hSHPd(1xa5ogKpuD=)u$HDB~pTnU`QZbYfW~QL^u=9lm+($FI=sYo?w=O)ZS_d;5 zyi^6jEl??&S;Uv5{DCfY)!r# zoMJXuZzKpfOk$_R%z4InHDjS^9VgMEg&(QTi+B#SP)1)DzuxtuOF;(mQ9{9a5vL0< zKwnbSn@;kSMMENoe9);6 zHyL>0)|7a^!PIF&52Hx~6aj$HBxM-UY79#gCs+_2PWS$0gDf(+|Otr zlLkzUpPy@LJX?Nw1vYZEnNh{FosLVG8LRnxKR-WeAZj2<;P0}GD`|xmaRe_Le+k2; zR!U7?_Xi72CX_t7I$C^l_5fb;aGShHk(;bdW5Cv!{?1qmkHlTlm0*UH>^4ZzRFXIc?j~~oc%k!7= znKNxyV)ow!F3}~EoT=TU-{M#n_EcTjT*Z)6$H1w54Ds#FE+Shy9Ah<33#mOqbBM$m zr}QQ-<=@D%bG9@okmh|3WMP;%k1ok?EJ(1E0_{xVW$fF-HxmkXNj38A{ z6;UJ@IO;6du3N;No*4`r;RKQTT1hPZvi#g&=k^fQhJ5doRMyLP2`;%&15z);zP*t` zxXXc;F7JSPUkbNsC4$})ET-au*iy}vbA%jp#I2Gp7*j;APF zw~%W{4{lXD9C+AO?cewo*w@yl4G{+=iNM@NbJgFILm3u4fQ#RM6RWH(I?fW9McSdd z$D#EP21r<0XpVU25lU`?u%ny@(70tzb>z|X%;8SBhvN|K z^ml>~|B)n2=!>sln{s^SMk|Mw)U`#t_&ntv1DhQm5Fa^k5M#ZK4-K=!?Q&WxpjbvF ziJv}e@(cHHu=(0~aAlG4QeOw-Bg3w>gqgS()^e9r=&Bxlpb!f!r)9^zY{FUsXy$hT z&C!S$F~?|ewom|PUn^S?YZ6gZY#k$;z~ScgdU zoii^hOf5G2IvuyZ0-P`htu(tjX5Izzvb-nqVQ{ADqm0t(IOp@$bR{-o4^jIGwNk^O zIM#1&#-~iZc$)FEPb{W7Q;k4b9P4D8 zJg~!AJ_0y0@O0ylP(1c10U(6}&i%jV1%r~IpDz}OdMCXc3QTZT{2)Cot(GGaajxPc zbBo=(%q~POjWVYtmG6WK51Y&$)D$0RX-sntulOc?#YGZwN{_h3Ca^x?FY#*iu^WM` zOx*Z0)hY=?)w#;pb1WL$&9TutsmL)wMYi}=?OdpTs|dDxu1jDJRG(G^?D1t6Sm;?piVL$ z>6(wsD1m4Fd_fqIN%rOWgD|H1ug2viPJS&KtrZ2-u`OR9prx zCLb`uxJU!Ungl>b@WD(-M+EnsU#6vDi+eHHGhSsyTuMcWTc`2`<27l4laHfAtOSQ? za5LZVX@rZ%xWpS^W7ejjNjLig0#mtSlcRUd0y9WL;7j0w9iiW)(Cv??pcI#rm%Eq% z;Q(@^mpmu*(5xFmA`>HfbA)y)NsK{D%4A87JyW5{@m6l9CV35z?cujU@}R@T@4t?R zg0+b}3Vs>^jAsM7l()gcQBJj|UT|np6d}shX~vF%-t#m%{0Y@xwk{ZZU(`=vXC2w( zcub&i(E<>d*!r<%G!}*Fc!T?)C@jN2_H)BFvNuD?s!mQU& zTw1B~ma+!4zY66MWSw>^Q6MWghkMojZ`2@q*3%LXv^Y}~f0`yV$TG3}2O5(9-lOG> zJ&FX1`{%3_JRbyFp_t)VbK_}Kpdo}|x@IIVes=8n!lu}+z&1{aDe>g}?6fF8Tsjfa z+v&ACmyFbFQ)109BO_bBO)&-KLj4lHl69^-fdpS$Ry2W4ImALsa2U=?^N>}a$i-MjpVVnuB13zWcd{O=^ zDOh=yZoruWbG~@o-mpFKL_(=>OgT%|q9%8+B@@!vr8Epw*_yQ+ok7R+tszR)7^n8A zz{cy$AQ_?kB<*zX;N(*Re*pL&Oy%p3OQv)SrMElNw$q1MDz5NJ=2(7CYvO9-PoUBH zNsG1Q`zS^CJPLA)DRFGB#H5x(uLWkakb4)K8jmafj%k=_ecVukj<0s4)Vh~Lkgt>15%-}6UuaC9j@ zpH1T%r=*dJv#O%}J*Vno{yJ3!{LLm@q8hxdc1t||8I10Y0rZ~uId&2YvO zWTDjiq?aEAS0gxu-@S#^pvvF(-alz|$I3yh zoXeULum1RC_YvoojPn3(BA=iK9CVKDdMMc0_3T;HSkrZu6Ky0rYw}ZkW#Zo@uh6d| zUM4@nFV%m9I9mKW2Pe{kR%+YoT-E5*NMJbyyD_-@?x*~^>P4sKUB1E?=M*H4IJ1sZ z@_;jX6RF&s@4l!vb(~D${VrbYG3D2q`&W-RdCrmvv-BnAJ^S_dpE3l z=#bW$gFff!`lhjpHUJ%uZR_X|ytr=nu7CHgzxJ*_FxUFzA~Q*zzl;|WqUP-aP*x%a ziOvE2mUk@KC5OflRGpM-9UW3OFbnf?R9k$1Oy_JJtkWVU2VxmIk_whAoeBo9lh zuO!SeCDL^rBOrn$|8p_36c9+a}%Mki7Hgq)?Ibz`C*PCtZVB zp7c5AfqGy&q=9(qb?k?xadxIo_+dRRG)7U92}%LJ=kd4Wbwb1jOk^cznhz>~ z5-KuA0lFjP3T^LLvog3E+D_|uF14O!F%kI*1ji@}7jhKU28qQn~ zu=zmwMP^XxhI8&)lt1jcVyA9BC_ZOm#+{Eq9JLN}$<58?<_&u@#N4E(n>T6Z<`?#+ z6Y_CtciNkG%*~_>jraEak`o{ z;9YQa5nm+lFvgYMzP`jmy0^+SRR*xRnP+Y;w>ST0Zl>6dmz$e?_GY@d8E*S}t+`pq z4Qw=-X<7+Un+KEHqZmcZ%?%Y!T~ap_GiKM*kk zI1f{hC~CIT-!nHk+$0}n$U^+FOg@d7&!*3G>Q2%N?w2mgA9W9yq;nZ$Q-9)*mPuX3EUqYJOX3X8`zZ8ba=xZV2Qr zsp!Ovz5k!^YdTZw5vLGKfVqkCDfIakg@it@{K%r#I}9!LZl3q9$-b-0<+~*MFEG4t z9PcK~5)9YyAh>!dZ6;5mv@^XGYPjxEo_D;-ZMnHs)`4Ut&rCPN#pHMp6x*t@%>%$! z+rWbqIB%Th)ct|#JXmVMmVA=;j8l-`pdo6u1a@f&&eP2Br0c5Av16T7;?#YOZ&b#> ze+1u}8^M1_>PGNC;q_^_;C~=>Blr_5&weBLZ%^G!p~Z95ohF`${{W3IF*_C-XK9$f z)|;m<%;|ahdp+H$?mvCuan>-lY=>%D?A1FgTwMLJezboPpKEGDU^!G@7vcNlCDg%4j^*^f#m7Kj@hu<7(Btz_gh0%bury z(bz6ZwOBT@+U#icG*(N&MB)b)AjTNImJdwtqCwjWr|xpv>(|B4>8n3`Ukz4o?&qsu z&BpFzHyh~YbK&ys0?p?&FTMU<#5Yo0qfN#Xmx?&Ebe;~LBhxP!t>9Fzc&x&uZ_WhRQgA)@{`PR4X!Ifj5PAfk^$ueQXQJEh#I|fCVKqu|YdbF6f6bctK{qE|?CX2ru(D^W`q=Zq*bByl63>KU zszQaYf{dd|DodQl?h=ceC}scK`P#!w{YwH(qE zh9VR_m}kEQ{NeP?5;(Q~dk8LM84kRt6FQcZ z5K0=BBoL54BQfH;r!b-~(t8*YhpUOOfl)$?XmXi`WEs(=I#dNCGHku3YXFv(V4!)? zB?c!X@^Teo?O1HHbN@dPWWDlx9$q^(L*Sb@!%OVc8uT?=eipkYoav&bXPZ6qMBSfE z`$ehYW0ZqW!{{=TL*Vbd?U6~>Zcdu*ia9F_8#`Z#iLG>6rsDpV?scr{ffvy$jO7zE z(tGeTvY;+t`)F4u=}C?YT84Kgi}cd`a$rIU!nRz4@IxRpOy6caBnGvOD_9(GCW zkkwA^d;2j!A2;U-+xaD9ZZ0HRM{!wn+0-}&pzm4%h03XnZ~!y$rs zgMv3DeunKc7%yQf`9OWFDb@lp2@^Fd^cw+C4^OuyN(f;YKt<_a@L6lujZY$wQ|vIQ zK?5Tf-6Q&HHSeA2hj7L?ym&#)@$RZ`(4d56@b79@p{t9ee}I2Hl0*};6Jn;+j>lXf z>uU2XF<=A*?pq_m>!W_~J)iTvaIoWV0s4UjvHf zIqevnF-y{7AH@g-%GM@!$ELAu6KCaTDc{{C+nl;~-bE`hP(RC$Gy+-?%nBc_BVMGP z31RnP+g;0&wU@|~rIeLzsa)16Tqh2*MSfI4!6`rM2%*qO@TnKP^-pz2;Rwi&!d4}{ z@nXk|vDNzw=X;esJE%lk2T1KS*tS7fw!3ts79N=wj#m-){Zfualz+}_9yymGLp)RR zM$xusH_!MJ(zB{}K=o^LMJaa$!_guh}g}7J? zDMXd1HY5@1Qc9YvB_9*^h=4Tpu`RH~Y9F}C(# zePqqa+aWl^3NFxob;ucj_8uA@C9y=46bST%kzf4FUC;6Ch#=h;lnz6}qxv(*1 zrJ_0_2_#V;EDM&Z)%lpTg*ArjvcH3iM&h!csHRVa3g1_n>ZkIT@*OqAKjrOd(UITr zNXm%H94g$Z?F_q>1s)W*Q}N(BKJP5Hve-!he)9(79I&wq_h0q^ElS^P!{(uxJR5`O z+aWtoT3IJKy?}_+2t1Odj~_w_sTn`!s{P{`T!UqNV<|z5{a5ryd#R#~sB07IB@X}5 z;N^TfeRV;Q98leEl6x`5QNWB&)8v*7^pQ<7%UP~fvrrbcmMqokRd(rz1W{<m`A>`Q$!aGCD0Uf9>Lm;b61x0XnpXKrlcZy zu1qyp564gO5AT^>^+1mxa3403Y^P|j^OfXYr0gSRaCH`9#EyA+IRa31sG=CI5yK1G{Mk_RlV%m*lmxS*Y;KQ8ziX5AQ7y2+gJU0+wV}|w)~KD|4c?> zmu!~vBB_}UrXelaXc+xcdY^V}?Doe`bll$u{(#>*Tw#}+Oez0`0&E1fD^BMEXWC$t zJ4UIMLObugiy+|_`RSQapTt^<5;JfmOHFUZEsz_XxFQX=v66LE0)k*GF~>F+us^)w zYMR%{hUJFM!Bk6P2jMtE1jE!G#C=38ghsn;+kGx#AhT}*_;Q#5zG10y$XA^eawlik zF}*}t*FNh4g||=VLE>Dqw_BT^2fScQ;vJA}sp(_0Q_`$HCY9R9@Bx^D^suFrin^13 zK?M-~XfuVA3%DbwG93;Twp0BvK*!gM>=_Yl1aNj5*J}TjDGTHBb)=}8qRS^BRbvfPTli#JJmpg$-eg-wd+Z4NhJx5nUkJv zt=T#-E5ekr;^nssNzMgho8;3XMv=!6y>Oh!628M?jqtol;B9+J>;zsDz4*_l0}PK% zbhgeDe+Wp}ouk9)d0<#*PnVl>o?Kbs{JP)X6%6cI{JfmTnHO!cp(M$zBC$PJ|-a}uFK zeDk8`_~bntAD55Nn(l@gyTT8GM^asb?v3!+tj#I3Vm^&Vn@V!caeKtV1BUD2B-GeN zpFK|MYb}*nlJhAjMl7hrC%0NQZ_TAW_QTW{&1o__*}_@9DEt9(lCXV=t7KD=H&JKey9_lzgOwW zb+il;&$l=#2oxl0U$fnS&gS-6q>XK3P5y|m6?0NAwkmG4s2vvwP6jycjZAX#UCBQ; zG?N4%C@sW2aI>e;EG=OS8Q!LGOWOYSKEYvf6BkHihKaIO66;C~pa+P$*FOc zQ}u2-1bi9OZIjY<(A1!h|drnMWJBfn&QCQ&hmSNd9D>SQo`9J z?GViy9HCdG@RR(i5|V>*oiBC|o3R2f>aI45Uq_Z1r$Cg)0yXv;Kjy|ZyZ3Y#?v7Tz z#L`8TftV#2KLU-!fzU2f8p|Yo=VxWWN}zBrF`RLx7VG08KFlooUYzF6%GJTnDz|Ke zPiex9f<**;*cwi4WjnfN^7m*L2NCpRvu<;)o*5pSR;U8%i_!R{MFFWp~AhS+4NXJjkG|G{c52^D_k=P02Np0vX zj@YX_uP3SCI5Jm*4$?XPIzVfV?MCfT(5PO`Bk=s<8~WuEWH}fD<4VaaNQN+E7}#Gi@_0?I$NF zpC>oZ+`z+E0Xh^}#?_)y0hWdUw)KLT-`Ick_u5jbw2m$2XE61ARBAGqwemY3#@J zfl=%ii+f0gdE;0WoEuw?RDtru`ehm=>$SKifk(Jm18=!Cuyx6uH3aeVF|bTlV_5)l zzKJ6L2P1+;G412><7X%DMhEDz-}K85_!SBodzHiu;-5M2FwqC_e5041W0>@M7GSA|BuiXAq%5!*V&&AGt1za66o zq`@+d)#HDE59C2;PyBind1dkz?r%&Xkqic5ahkJP&8^fMgImJRQZ3ucc!X57i?xJX zPH&zvNtwX0xzJOo95sc1em84OV5@WgT)-WUkIDy9mFtDvRzN|yEmRf1!1fzLC5M?5 z#*79Y7aq2c4ZOfxotoMziCv`FFyn?seB0(_ktlNyieS~dX*Ws>e0HHg8SA`pCRr-V z=!}mOn8!@-5%adgDI;(qlx4VKsVF14mU&P4&7|^EY_=PQ=1|ERta01T@{J8cG_LV6 znqtbKGu&^Zv8?=Hb1?%z3q1itM0~*;YccGyx5xh7JuE^orH!kzo>fSPU?3;oSuU9^ z?3o)F>A0_Rqgu3@dNz}rl>MwYjo#S}Jm_Rp7}b4LifLBSkHmVK1n{1pQ}CAHtxdi9 zovLI4?0y>dv)=tT*b1`&G{@K9O)b|@i!uvlY0Xv47riAZGLs@w5HIXo>S9W%elA|N z?a%Ye+N1OwZOHCOCY1-md(Kv-G(=fn1SFFof^DOTlrS4g+XNJ&z+^v0qb73F0a&(man3#k@kL(v0P|6+tYc629JASpfpZu2Ywcya&z`I~M zVShNW_C^CkOiT)FXd-Sdu$A1Vj|8Q!+e&_>`;0SGv&2@@$L-8a2kTi4iT=OA*L~W^ zF?9|U-UB;}Qp@C7? z*3bK zlsiv)+sZOC9!RuNQrF!)_p-Mim{0ch{^M1?^(9lom1othUvdrEW2>%3Hy_)kW9VP6 zwhMO@iOxexIVkvGT{(vbCf!rn20Zs0*c7Nv;+O@|iO>Ki{DtnM=stm9G@{IGDb(EQ^Yj}AR=iAG+^0cw0 zdqCA#JwZ^Xo(!zISWj|$pQKl1>q#C@yuRTqiJ3SJBjB@ibFk({RCO(3pv65W2 z1y{~9$QCLZh>2vga($5KwzWsT5@+>X{!R6he3nBK{?8qx?(O{B#J8MS7~aP3J@l}h zdrsi%m~uI%^oOtK%DHA8wjTbHp7F0K9B8cmeUsn=3{8iOWyI@}@j5)s{5UI~@L;9W z|Hpxq6E||Qa%|9W^+@Fqom#6!ZA_~>diU8ulF1`4b!Hq}bWCS>%>F}Rv-9M!5Xq=Z zD%Y3bRZhfm3>%zVHCq4mZdS`QH{H6(rsfkvy+5oxn-SkZ&Rw)Hiil1hM7qMhV}aJ{ zSCkq(B)^_J;DAjlL80n+Y+cQp1FOQOPrs&5!0j?X(V}>@W3>Iw6D1O^0Ep$A(Yi8g z-XBnv%hW|TbVb}rv|?JCu9l{E)pQM9a$C4^Gg>6y)fXNVGBzXzM0_pC$XEm0;H)Wm zm@#K1O+^Rz`I}>+QKtY9`2525^d{=Gn>(KJ7Qb6{=tdEr1y^_r$8BQug! zjKszPO>UE})k`sRR>nU|+Omb=%5x)?X_iY65VY#+b!~!r7f{ECoYMrRqPluLJjTNo z#oNUU0Nj;+nV_=(dYue@94uRJ3VZTf@Gk12G+7-P{I!62UEo-C0-RY2+|p84>@d|2 zg)2$U(se`ZJqYaw`H}Aj8@ddo`HnXnA3&nikej|;9|a3rL!5Hije8+??#=LpoqTd> zuL$;_NuY{z&QkPopnxRt%_N!umV>9Ii*PJ3J(_H8LCY*9pG zx@qPgh@a2De;1w157#u$=Vsm?`EzHzGxXM#{8$L={hw=hhJNWWe*F7EXXw}d=nTD! z*Y~zkL@y4Kle+ppL$S7+*WPDCybwL3t!i?#vc9H%5DUe%>V{%IO&Y~%YA4%)8f%V zUDIMwUl;k8N&u9vK3dpR(+<{U-g!P(IDK)ffmzL*79Vx?^w_Agf`R%w->&H%wB%=~ z%7x9bi-Hy#2) zh{cZ}DJQ<%_N6&<=2-kVehH}I=6pX`*aoPb+9kpeu-K{HOSb{$5dM8i4ToZ_TN6;t zX4UNRH26IwSK5-(1pB-BQ?aFQ5%IU~bZ5nvDFujP$N#=*B_$pr)Mv^ypiWv9LpOc9KNgj5_lVmZ4g#Z`o53t$PHC9z+2b{cFtHeN^9 zsn)2D)0H=v$QNciUtlKBqqS$G)(b~b-|oBvOkl-eEGJz6UY5Dp!eun~R31AtD}#tS zwkpXI|7;Yc#W)$t*+_dZ81>jcUTqRr%hX$Lit&`qhSla|ZTz#`VQ216#PMJ=^%+Tq zibFs4f0cg3)+D~hJ4jUdGHV|<-N9B7ij%N>n{@5EiPVeN(c8Szf5v8IHeM$5t1*O{ z#nN+p3Dt%eNl{`16)UP{kyZ?5m*ye9KkY}AJs-VFgf+GL5fnMEReq%+z25X0L1Hm&^y^q{j4^6pj9U@t7u@EJlDe10sarco zUeeNK!%SHVVFON_E<>@c&a@2y$8j@yp=H)*m-cB`-L{aUjk_QA-bhl1u{a9AsU_Pp zz#}n2Vc_puBNXYiDKvRsrSr6-#dNb5q6~QRSIipB%s`)}ZL^6QT>biuylw)R+*<*- zlA6a>Dzfu9?E@bvYoJ#-!%a(0hV;Dq4BcPJy$l|>RUS*BsDaO-FQ$+k2n3z!+X5pO z|GW2Pw!S=artSoLy7PBVH*3!Ck({z~mclV+FFColZ)d5-pK@>92>!$mefMjw^7YGo zme=4EF*549ao01!RoKw*f803Gpas6}D6Iurm$p(xiKUE|0)+D!ojvzUBs3j_ry^AZ@{F=byc zhwT56C6~J^263v}dk*7NjwwHUli=r54n_jot2-iB#i(y{psV^f$tPKeX_sL2NBIGjsNNi`&y+PIlHgL+e zXNEi5ieoJblx$Ch0;^DLlbXxaC&WqESo6mFq1ZStr^7~^Qa;bCTGMlVm&)Se+bXZ0)QA(NmF76`NFL$1^?rPu=Wz*b_4a zP073X$N*fTA`)v8ptWU!e4uuAF1Ba7bGw0f1id%~!iYdf3@0s6>~1*mbqw?vj6W!w zq&tiJXPvE4chp)y1X#TFCuUl(^2MHe;92z*He1ie0!rUFOs;%r6$*yR>Dpu0gzX?Lv^{z#CVU!(%EuThT^|tKN}AiZWg+kbS89=SQfwEay9(f?a|+ZTH}{i2 zS1GpZ31$hWUG(wYNb@>orn{zvb<7NX@>z5VJW7a&k;_7H{HPCSWV=GOt|yVt|{um|$j zP}UQ?(58U1B2N|;NOqY%X0-nQk}!`lf(N-qni~b4U~CH*)}{B15kr&wD!7@gT`G0D zW>J3WfWyTQ<=KZrPQ?q(w-3Tt^xy&&`4vUx6gveQ#vJz5xIXxJ3r9G{aISpR;+i11`qN?YoQ!`ts3+6 zv{g@7p|^(v$E$xC3fS1yPVG~4hTY_PF5$`z#OOGu#7#d-Szz+OldR{pd`ib-4SO`Y zw>ZZ0`XkgPl$039&_Th#rbS=Fa8lDaKp(3T`)iBs5 znIG|OC=MKR?*B5ot$bn)jX z!fj7z;uZN-d2-~>I&@@MEkj2ltt%C{jHIJ7vXAY6VpF^2(+ zA|;Q8F=6=d1gGviWMy&*8m!^69lv$zhVn!^10qmGGI}e7NZiPcQ`i%0$Q}n^4sXlP zOB|hrZ7`nk*;|d$z!T{j4AmA2fw}sck=oDagq=IOlFz}?EEqnHDs{b^^Ktw!z&tS| zFt=izcF)4tggP{0A^}m}jGC|~VX*=l(5P8E;rsJd-a^LWKE<)UCGO%bs5}oU4{m)2 zEk%q8Y9r#p+a%Ug{&Vpr_T*q}4;VQsrU1_{{FIs}-+7D3cCE-(%%GkD@cL7{x{R=2 zhC_zs5@tM*(~ZB-vo#ji9@hgQtmLIjkTP#0{8h&(biXX*zVfm4ckO*z5@TvTz)DU*R?uX|XX9j7$ z^CLFugnXod45$q6k?tc77TYSGQ`!YTnms^N1SgtFjd}_O*)0QcoPL}r>gEi>uH4Is zjQvb}2&|5t3nN+wX83RVAS1eoiSN&duCSO`F2*oqbsmj%*z}7hPreQPpq-7aNAZk>DqW1S33rEevU!7}AIy zhIElsmkDfflZ-X&qaksYx!OaH_>Kev>z(_RZ(6PxOBtY6nDbLk4LVm*qzz5?9z?(n zn9pGiI^1hvq@U>+yv1DxVgC%=d9Z0y5#4p#3e4m6AHr018o zvoeV3bMSO*hpB?^><9+7F0O^=WWsZ9=P(1mEXzSU6u@@!oVrhl?F=SPtz|pEaq2Gf z*iJp2G;BxMD3KR}99qoPVy9EcW*1cdyZog*H9W|lxU<~wpyxj4@gP`;$AeUeLGz6` zk#=>1SXCXh#`FphLnQO>G%>5A-1JqOL8p3oOCKz`VueA$~ifM zIW%Vnl278TW1o#JAobkZ12w++8Xr*?oZ34Wm4Gvq5;87M z;c6D@;2!2WfA*E-hEe+$=2V|6U4~8MG|RC9~ua#6_A;> zZWSsf4;r2CZaG`p?Rx&Qi#Lkpg2<4?QI3&{2?xJ6bqBcHy$Wxvqx}m9JGI4N_{wPI zZTbFHKur_TZ+u^bFeP{LO6vA;u%sQ@@{U3H6FcyAi=xovr3Sl}J_=p}wFVuEXW9kq zNcyTl>@vIpwi1eeK_f#b)f&VL#S3HuS@8@7WWZce%vwLZhBz|@5z01UosJW;2vbAJ=`Pt=%@d=*SoA`y(P;vZs^K1Os^Ck z6RA9D*B@RqMafu_+KauEG7Kq%uELw~9I3D63Kmwj<0l#2!TFB{RurmeL8P+F`C)ye zb2kyc%wpt{2CZgU{#@0yO!}sv7@=l2%c>o)$6cn&+5%!dr0|7|HV=ISrxtV-ySNC& zUc_Zd`&uf3((z)=t0%+&@GM*(@-;}bWYXi1kABqVFQv*L9!mQCEBkvu)V$@v6FiV3 z4?q9NPkmWaKQKrLDC<$GIK}n6C~>o{l2aV$u-u%KEODo@Q)1chbT`Vj36guMS3o+C za4J0AE!#=4CyXz&*1hu4^0h3=zG>+=%sPttAd7a{vI=f|GMB1Un^sLy<8s zjB}8LN7w@x0yQA;K8{p)r+Do8UU6!djwosv<||$&-Thd-Q@1z~%5Q+m%YD84XpZ)X zveR@a%a*diW=F+Z{;{V!A`9ymc6C}xLjxL-4wY%yHHrrgQjv8 zH4N1U6Q}|M!iXFh(7Na+G4RT_s!a4OKWW?PhTab&9NtKoWr&E4{$y$lIwR9LP>JK& zt4`f4@I1t!j7+Cio+MHj@Y1njRqZ%hxGdEhR6bT{Q6C%4{`BXgvGsC#7{fC{0_s_g zR&V7}xXlK-I*m{B!v+%;EmSo^1gepRUL3%#*=$t`vZorT4Rx!yw-$oWnOfTUV9_|f z7CO}HYbrFe>QleQ(V?yC2VGE~%t~;x`TzrfCfS2#F{ky->?jtd`Nh7(b#7S(3kU}(zK_d0ANkSj4JQQ)SfTvrFC~jo`G+L!Vn4p)_ z+);0EVL_PFM28LIplmCT@Cr2BF)}KpA5jg4Mm=&5H@rU3_&+cQQ@hxad>>QpH7F34<$n^2aq6z*FG6O;<+2h}uvv(nydH4q?;X z^yZLzD;wF9EJP6`xkkKU-`Fk~gF%MNOD04sJ+oaDvz<3NNE5M1i1u~jny%F+b5_bq zv*G{^vUWQgH$*6DgXec5B%GpZbtZZxxNY}?j%I2qQ>P0mYN8hUn_ENGT_9-1{&2JUd+ zaP|IJL(Qx2Pr<$#XmM(PDX>&FMgRz%@n$~xJ)R1HLMyg0;qXNNmqp_GwcQ8&67CjF*PL-VT0UC=FP z@G}nwaWmO^UK(qzd5b6ntc7ChxW{7ZYj|e>zsijqgC>huj^+(uM*QOffaZwv?bXbz z?gM7^Dt2BHJMOXX_gLfv#)9Sr?8U;f9oa`&eue^eJvtFSYAjs-nXEMp(}ttMps8g#aEp!Unl5YMwPKvtc7aPJzTG9h_Q1|1%acFW zzS{ra-n+*~SzQbN&&))K5NDDaHLYl;N^7DR69gnmH4`Rb1||@>C@2y_5=b;8F_|cO ztmc%2lENTw?b~vCdMxefYi&<2^qgMk>1hq3fVVbil_*}~t!6|^v!Z|CRo2mwp>o*kdi~8&fkC&8!j4CSk0?d_KQTy%m5(Dg+rm9?T+53zWgFU zd^lRdzJieb0=6}=p*rRWV|l`xLB8p{KdRZ%i&?O`BzZ>LI0fi;fsx>p(UCI~wWh{cn&~1V-`xsd<8{5x}I2^r^T!Kt2ceHRR z0)&8H#F&{Re6~3M%VOWB$x#@tRtS}Ic)dSV_Ey*9(Qm@` zMPaC0UVjWJ_Z4Y!WH##qy_3ONNx2oNKxA`nWxkL8lAQj&`=jSGvj*!&^o$0RTN(W| zx&di%nTn(OzeV>lU`dO4S!XGKP0EB~{TqQzR|xuTrCio9vk2&&IaFL<*c)57Y}1V1 zBkRt^$sy-LmfNBoUmxi`*ma#`VfADknke%K49gmufOa;&t|co?u~_i*?T1XbHI!-*I`Jx_!-Zp zAmu3KM(@EpCi){)F$~&vV?v}DfS;H8D0^?eyqzO&`zwp~qU9p3BUC>mq7#bm{rE?( z?)$SgjiVd;k156O`$6`?WERQp8{Pl9u%BHoWvMfOi&?(Czy4td?AG?qI<2mr722^&A3!Wvpg1nHS&B%J~JxYqwIVT~CXJiFid7 z4BZqmb>zQ-xG}=+9N!dR^Aq?1f(gt$xE?^aUBS}e92A2PnantkAz`q={b1KKm*K4` z+!Lr@Jb8+UpM_N7-w%q9KyR{dLNTbig~)9FiJL&0cH(%+X{^5iGhg5F{fF?aEwB@& z%zA7;0E96c?xm;u>d30>L#NSBG|ttIr|C9EX&9RzAxpP?cDIM(-R@@arL%Cici4@h z%W*!PC+uw+C)ZT(#2z!}3@z$BA$+UV!<0e$HbUc4~FQ}(+gJ*7rhxl8ut zDdxhFO7U!a`}CQ_i;1d$TeYM#0Uw?b>ZJ`Ugo9DhGVD?1t4B+pLmz})wRi#fpVE6; z^(d`^?=OakFOqEgZ@!O=FjC35^yx#7Z4IKBzZ5|-TqZE z&sHXaar10BY6VvG;0lIC;U2UcRIqP94jBAUuRmQLIN+Gj3MszT>9%;5Tr3s?W zUFn5#u>ickh6gdu&aD~YuYCt?llHyH4=VxjEWhk6Pu}&Ip{~LVRqRt2Vw&2qLq`1H zG45wBjpTPb_WOmt#J8GgQ6gE=3uUt>V3ZqWvnLPP@`gVJV7bXvHha8UCgys1@|0Iz z05;0J##pGHvlT#JhR=z*6tj?i+(AE<9q{B`ovXY+>WNugx24jL(2kgJ2I?;jvdU7_ z2BQmi^~S{f7zZdn+v|f(XvV9JP%;rA&M{sCZxxxw(~4#`*0 zRGb~-kJKov`HF%Ehp}cUn_*?g%Bo)MMX_xvFYOmu*XDouu%O(~c%Yr@A1^!Txs#OG z*I=o2M~mf!&*fWucx*hor{i-yc`f55O52b7Ey1*s5Jn{bK|O*lv&tRsvoP@Vyr$3v zJ9|u998Uo+>70h9bWZMo03hYYfI)RW56hYq00^>Z{7$o9z*pPRrSC3RE+Ms_$VKcJ zY!n!5`u5}@Lfb+U&51c`eWolLiR7adL`>efh5kme%H$fbw29a7mD%L;q}EWB zNK6~9Ck3`!!>>P*+ze085@3>)Q0#Z&rIt&(e={b-i_#~6xJkTyY+R&3iV{nIpx}L8 zvivMmVzX_OC}YCWS~1!bZ^6=WHK#fiZ|LSN1yV#xGidU^S4fj}Ys~OWp)rYMdU(Ed zxfveMn3rOEdo5+i5ZS{v{QAQw{qHRYspTaNv!b%ospu$C2W6a38FKXKXJfJ+FvZ#g3dT}?V^fOwu1`b1WlRxYHo0U&D*CpPF}k@`FcSGT`aE%>Oc~+=MuB z-)F0bo&&s;S>=y};^!&*H>85s9)3uB&w2}oBE~CXp)7;@)!SmXXH$ifE|J44no>Rf zAcqZXO&YyNFg;{dJ^g$d&nF>7JVi!*FnE*?4K+;midVrh${GIVL&+djLy3Q9pdu3K zCe!HR>Cbtq}VoUx6xi9lR{J`x80t~3uG_a;47 zdm^lNuqx>f*p?Bv_h4fp%gLsr?0#_gPzF+(Ix`q4S0XikVw=}Ds^yw-2qL>YU;Un2 z6p!ELUzvbTB%8E+rYPAYX7HPT^Z^Mv_*x_`1Ye1%s&{4Oy&^EOIflr zZqNUep2d!M?i89WBHz*nQP!iHWp|##B}0A3uq;{snuDEj4wBq<602CH@XzY!+z~r? z%G?QypSF#q9xW%8tjX9j|G7z)55uUa>cU zID)mk{R(+DS)QI_P=sIjDkE7UT8*C1!!rbZUScIHoW5Vi86_fYAHQtOFy{(V`8Qn< zs2>!|n4^R0J8_egBO;VSPx<@a6uiL5WN`nROtANTeVUidgOn@Q)TM8W5|| zLV5P`JTG$F0n9UveILgdeR#d%9SZ#cGVTQ_m4^Y_;?Ixzo&^te>{cIs%j%Z|STqic zDg$mLcl#XNwa{4bR28ri{1l~j6DaWj=Dp#Q6+$wIsCC}FeX%xH>H%X(Fv#(~FM{VH zJRVGz$8#}rQT9tuc=BqD{ZbiPR?L=J(zU1-E6px4ex9{{)@1xFoJyI2O$;*NT*+Dt zGfnm_)?+J#&a4DI=AOBctW)K!w;HwZA$-u>k2&d)5Z`_5`2ph)$5(~{b6&N%D{Bk7 z@#gIq$7M}J2s<5&#p~a$5F10d=*nhYTgB!mO4UM#XTxROO1~g>Z5nb=>8rti*@McR zf>g8Y3Gn|(gcoHjj8FWoA-{ADPtzbS=GUfKg5XHBtm%Y0^DJp*?V>h-Bo_XIBxAF&$ZSC(7@n-a z6%v6dgMp*+?YF(bzUP9wUPTleQFt21U|7Aj7h^DRwAan}FuFilZ^~{0V$wujl`HO* z^$xzTVGEvRm1+&NWjyBmkrgqPIi8*w-1j|G+Q0vGQDkftaWbEkU@jX*8qJj(FFV4Y7DZh?Mn#Gx}HkF6t6n!Mv<@0_*?6X2)ZJ3sCci9EYPf zFieK*F)Hx%48fNLwr{AN1x@u#7u9|5Flpxsucw!1RbHaP3l#8JN~y0N3ENl0>4ng| z0=LMt6~Y!GEhB)@jDDfsG-s$WdCCTeM=@oBSm#GtZes5lei4k!AvrV+eL@#Po)6;l zgii>QiJtgR67|Gx&sXOHD^IVV|Mk)~UW=)@*VA*6YW#9RH%hL?Pm;DTisa*mW71(m zPen%|sQ}vUo(Jfb=EKSKBos<@59*UMw?7gpdnyo_uk?aG&$l6~DAd(onY{}dJ?iP% zz?8}KDTYNIBF&XGzzbp;xDQ4B z%WN-QB_y;>5t(i)pC9E|r%>BoRHUpSm&(eAuT{M6>D9Ivas;P-z#nPC!|aG6Az`?nEsi|Y_GQ1IF;hHVe4ddpzj8W~fqa=t z#%3mKSVc*^xnN#o`3s7dmjw7`7^HH4DghlcQOviwwvbS6bK!tJ+%-ZU;x((lbLXi> zIw%i{?=S2dLVYi=8G9sf0c6Ed&LPINz|ZG=flJX5^|9V5yMjW!v@QGZ9$$`4JbwEl zGPr@u#6E%vRTyWm4EHWcBRmszsv6;oxT)-8?LTIOmHne0-&ywf9vC~m18RI<$~3-% zA2Po5T2n)R_!L2HQ~}x~R@1{H$ikl92l@A{f0H={a;z@;tFbYJ)hWMbYF6w0x`-6n z=+HGM9c33mW^*WAuk#fm0LuayFF07!ri=Z3Ig=4Hjw{Jf+mZ^jy=Ziy?OcCkwM?*u zvQ;4QC5)>=ikZTivym6o_=<=szWlfBM_yIrDOGWVMV%)Q34~J}lR(5|ma6%ti_f$O z*PL?<7k>VteM(CC2Z{+s7AbR~u&=W3;nIhY?nJ6na+T1VC}L-+og-0*B(u*@*?#P+ z`yOI9*0IlD_KJ=pk(8}d-3g?5k^@^aA?c0xAM4&2=%0|^K zX5k9S*@_TwBjfDTG7j#!_JLW%tqjx;+hhha)xyqF&EI4~1Z^K+0#XKQ`-I4u0l}nY zS%X0I_G-P8wVpYbgfQ>?Sw`wn@&N~E(#Sgyjh1&-@-ZsG0E(ll$UAg%Q`ThI@=Q<9 zHt~Wjl}T@~@HtW)xdHb9!j!YlmTrpSXvqc0MGg>PIif>k(r&)7dzJ-<-FxU%BW?sl z3i>V$*Xs*g{&|r)k$)b#od)=)pm0e}n^eNm*580lK z3qVS7qYg-&DF1}YhD83MtDc??;mnR`2Kh%C7?*#_r6(K@5b2e>0^!NI2tUyqAwfZ$ zFCW&l7pNCCO0KNY+Ef&*SY}?C_2Ix zbkK1~Y%jzCyU>pRF@US&(r0a|p!ZD*FCZRX_Z|%AO3G7-lSwUa@naTAaw9$*5Z`f6 z(IcYITc9>ne0|TzNX3_JIS;F4+vA$wo+0z;lssEr6@IHsErMl_cfHW}42KihD+Oh0 z)N~3$vk0NL`AR;@>W3j<6Q1Xc%4*DRtF#kjY+_X~!EoAT<)Td-7yTlH9`8Tt)W=gx zc;z3=)+;zB;Y|wXS-VYS-4*@LoAx?S5(pa(kU&hOXF?g}>_-SYzJ*j$9t>5$k@XJP zac9VgG9@}E_TS_TI-X^-N)c7>*O2`iY5;Iv?Q3r|jJStI2^C;ggWBgOPGFjz+ZTRpn z6^HMgPBzJa?#_z-jtq$bWU$pI$Wrp3Z|eUU`E}RW4w3Gz)A;!V3IZv8zoR^>(o-1? z^d3}tMS$yPU<)|mJeX4AAmco|lH!7W&npAUUhIvr?)V}Dnv(GMg?iAZk=7(s6?=LX zQt2jb_I9@t-I$&ffVVj45#~53lsK5ui62klEV+IxbtCy|8e$^A*!*WS*3Qk8+@EK_usJFmnAdeWVg?2#Hp(nB2n({?MnDT&K3{ z->Y^!!PYfj*6EQinn|reSsFf!Qt)}4+A5OK;{|`hVGh$N?2py(Qn5kGt6&f6{jyzm zyd=t>pGbE0RFL>w{IR`q=v(T{_k2cAIrNLaqHEEaC*V!rVGaAp^jppY+He2ISO`jU zlw2LC$5*W^Bzm4f%JN69iQyo|^Rq|%j;Kh+KZm`B>R$@>JuUwAa{Knu70i(pC^56E zkFuP4LU|>YBS;qx6FgXZ1o>v|K7erd##ZBmFuxL+k z{a>=<{8Bm{`XgV0?hmVjmU!ypvt0Ku*1^c6KcLo2@OQCDSjM^PVFcip0pUJ4#;`z& z{GwIB6fh)4s!tyJQ3AhJe>Yu$hZfPxhEe)(P?zK5T75k$Ok4{`J16P!I!W=vo(+)+NvICJO`Ifht zcNdt^n2qx0kK%*NhYy4+{C&^Qiy$?LJnk=g3daZVVGfw-1)w>PE>6ohk3J&j(Q$lL z&3D)xf8>NGc13bBn<)&Tj&=ey;Sv#lfs!5aSzAEKvWzY4%TJufhS z)6xYtalR;H)%UuQ1N@>Ef8C}`+16CM!%vqD+%_bm@gHQJqX<*vv^mEPeJ?Sdm3;?6 z|G&|di|np+P???^vPB@Rm%71nF%*G6%~Gl=&5?viJiSNxUoXxQ%1EgQ9U0|J&3E~N zQVD*-U_jHJsAiR^_9+fcO4N_60pg>oe;!|-n~x$~NL~H|$NC2PI1-?2hYkV*j{o9c zc30nndPAZdRL4V&2(=DqxPG!7lfy7ITVb=y#TRN5XsZC3{GVl1zHQ0=h42X=!?{Q@n0$Mk|m(h-;R&I z2}f7R{RKKC$1xzv8(`H}v&`Nt_M8fcY~^aBNqmq_7M8-eGgK7{e`TRw#isu*N2T!R z3uWCUNA1eE!AMDZ{3hB|dfN^BMSjX>$0c``V6rk?pcip9X9(5vbL0{$CXV2oV)@FB zIlc%a*pB+>3L``y;kSUg|R=)ZV)FEWr-GDO&6hHQ5bAlgn?eLp3ep?QW_F% zS1yjFwqe|FrYo3<<86rdsY7R(_Ms}%obPGz$58f`=gxD5aWG0*d(ALEE4Ye!VVOff z%zE_^Vdk$K5oZ2OpznF*RMO_-Anjl0MM5tOqfI~yeM!Gkd{hh0`1nMEwri2^NcFrxGb;OD)$lwj3Ti;A^o&{H4Z3`q4LtWej#7V5 zKYz=BY9U)^oI{ZlCRoJ~J}eM^1hvZgA&2kC0}cb+aRS_|r~ntU8Pbt9FPIxB!cO=A zOFuNoPm(Em74U^?2iG5Rpn@*iO}4z87ox-OBLA=vIYfvj6@^H2c4`2h4)i~86y1w# zaiUbOhNC-1ShLT-qWJ;l`^&ZO6eTd<7Gt>Y{LyE(>0yx~gyo&ZkuoImm&ey|d1-2o~u#X^`c+tVLHxinx zR$K%STeeW2Ij*Q*@ZfBZ0A(~wvJTv7&Y3}9-Tc~(+wKg>{oSe@&6P8o)D zP@X&*!;m~4nX@w*hKS9(K<8vii9RQ554Asw?Y@3brSM#M!Pk`@I;KE3K(FaBEe@*VE68IR7tG)yBisLG6 zHe!!~YPpU3+IA!|{axrmyZb^s#=8&ZBam^b^~hZmH@xfz=^(C9$J6s~zzVWcMkH{k z*VNHq&z8sGGAy2geQ%1KTaNJva;)AQ1Px|lJAwy=S828-n@DIOWwDJcaMq+ViPE+s zJYq3`2nx)!yNvo%*{BsEj8Q~+8R~nPmCJ+bIquBoDY4lWftr1yO0~Dd42b}5Yy&vy zCoe_KT_86r`$qN;>r=6^SF#l_;_Iw0PXxX7{Da^uiqsCXZ1 z&}aNmU_RgH3r{3|h5Y5^WaH72wcqW(<7wI4Y@l*AGwX6}`|_^Fn$;QpG3&ud#V9JS z0K07kB2)*;*qmC%x!t?>1}>X4*>m@9U-k&WZlvb?>^{WQTXWey#uzyt z%fXkiWs&xZij;FGW?!H4G|Qu&yeUeU43rIG*Yd>rmq#PBomkoQT)^}r`yi7FnSE8U zyQHo8*(?bMY41du%St0}qSA+Wdanhm#TG>*09NmzJ{D`*8bw*BXucx+&G@O>dAj(i zI_@v~E9W@YvDg^i^Zf)$BBu8zSh(S60(n>_)Tcfh?Pvc@M)5LPsU&ua&iZMAtXr=H zo><;9bd19xgn4zET}H3O^VNNr0(pAx=bw?!N7>%{!l~-MK$#^))#5?sKd=GcEQq_H z=1k;-cYVKAGl`=g$l~pC@i;cxkxORn$8*FLfuj9P_-sLn2^1^cKp!XQY=ya3ZNdmQ z78H?&l#4nJ@E(vBdcOK8g`YY63qE=So2E@RWSynRBNS<4A0TY8Qp|CweGo+3Q6Gb~ z<$lP;tfO*7_z}E&L7nl8sxFAtUdku_ks=Q|Hpm%T2#oBr&_I2bAh zA+l+GDK|c~Y5gK6V2_AUl(caz@({;s`JW{sBo!@x-;*~B;ZmFw?E`;g*II2_*J|uh zCzeAl_np(Io^YqDBxIM5wK z2ck7E^z;2nTo~Ae`9N)qcs zA)kpN_+r)5hCZN{6C#{XQs$a06&?}hAO|54e-OfEKkfqZs!Ay84^&Vmet_;E^t?|>t*hQ$^+Gr>+!Hx zH7d4ObOJ*x=1(S~J*7tu6{sD)BG}bvsO%+A&+inq!B6Q5+scaC*xwRrE5!1OZ=BAL zVXCH0Lv{zt0O)siRc1fJF`NT=YXLp65cL)5MclC zHn!_g;Z+yCudTG0c*;qcBZ1`g-VnYUF3yBZ;t~cd#)BDwjDsALQ#@BR4l_lS7>>#9ycapFLKnj7a8Uq_97$7USt&4J&do~x8q3i6!we7a3pK8Z8s7h z?)w<-xL(5^?}K{0g}V-DlaZXs;#-W3W^FLSfIqAUywNroSFCswwVazmIE;Fby=bI(w#r8C+%!_3j zeKFbkYk7jc9q)a_M5-*n%El8N$*J5ki?ZCr40Mlc4btpm;9e14ie{RLHn%(MmAnVnk4(<^skLHE*FZTPath z0!qAT^!g-#MQbzhfI3!V%j&qNk;5+}SSokgkj0kYf1(VVe!#!l5;y}nFvu>sZ3rz& z+j28;FF10w!qF2n5mwCKYxxY(pA+~wBl4WuBF{U3|lHti;HgL!Hl(j-72kMHB`umO}B%Y3t z$X6Vj`Q`+Nc*?lF@>sd&?g!bI_S}7cdG?cdv!gfg(n7xZ#HQGWAM>ay7@-J6?ra=O zur+o=0dPd3H~Kwk^=X1m(@q7G9!4PJ7}_*3k;x6=1t0V-vIwkyQcVp2T?{?3 z_|!&E#-`R@-QjZgIiN2rADqY^ zA1G@lU{9q|44ldn@|7UiOd0-CWD#Xyipw66x3ChNGNAOQ)s{H6UG@l{?!2u|PPWbN zdp{JpF59-T)$1dr?*lT^*x^zNXq+gdicQZdh+>yrc0k*SiO=3X7xRAdsM z>wCKnMjh}=Wpn*ryuD<*pURg(ThfM{2NY!iuAB!%=wZ+CO9!Jjvu7wnUIL@UYsU&@ z5Xa|4g$GyB9c}A^USiT@WpeV8F?L}GDsFP3;R6GZZ&l>N10GH5zu~AXXt6sv1`&av z%h=_~%Z9MI=0NL!c?i>3>oqK6Ek^iUn7eUx5i zN6+Mq2oNlZuTvBz5Wan(?%a$%Rt#7X84IGsK9t?BKcs-T?}^Gn3BkA>y3-#<5f(2EU__OOl7%QD-Ba>_-9P0PK>5FwgCi^bd;@o>rzfA0 zLUcKyZy(r8U1nA$OjY3wY>1@7@TGjU0YE+(>g!jS!?YoOKX$40giv-#hxl6Prchkqu)94#wFW_NkU<4vhA3X;Q4iZ}0im~VmwZ?#|8IsG z68t8K9@32;{(7X~1U)2r8U069Wsi0gDs)-lS&=`S)QHXSD%}WH->MPP?YK13J|f-Z{`JB)YR4O7-N&eFU9L;JeuzWq09ZLeq&~)!r2V#ISR({{?q6HL)T;`C12O^~y`+XDMG{9==*v>%h>#z4Ij)>4NZL3lB=BVVOE ztsQw4=L_QK1Upva2u@iLsA4c1Q1S_m8WtnJU9|6QPwhU>ocqz7(bQeM#;LCTeKeJ0 z_v)>s{Y;JEmnuf|eu#lj!8B7!U_wwu==||-c?-Y!tLNL1PA|TssK^Soh8sKD+gj?v z&26pT_O|BM@TK0Qv?W1FwWwLjS;w2J8=KcOg*)SErssERJUXo^ax zi;=z+Svp~-mu{GDH8$|zwY;5;^=+*UoyAsl*NsvOww(G3wzM>^ zscRuudso=o(7d*>wG-G#nI>*^b4%kCZ%cD)qqnr!LKIM!Jw~#RB$xechdOq|jGKOv z|B$uBy1A|620O-=XxPndT`djX#&z|L^kS`UcT4ly=CGvog~N?&+r!>)o7Z3I3xyWU z_ARdTcD0(0k>kA2cVgD(3+txNm{#g-TkVy`dm9>CI@{|yIvW*c=$h?xQ)kSa{-Fs~ z@{ucGHC%`9(7A_9zeddSNGugkt#X~N=5igL0EccJZ~xon*`b|&HDsO0-BKL+g%xo6|a`m#I_PUq)jvWOw| zt-oXG&3Py1TL1LhpDcar*~54ARiFLjbI$Fvbhu+y?3VA;oa%qVj5j<6-qBcJyqY4^ zRd`-0G`e7+m#fqpobL^mR{LfLycc?d-UUk*dlyuBD;6x7?_YFYkxEakav8kQbR+Gf zDXQJl_T-3Y+3G+3j+5-|1`pePI$k{wRj;bK;=xEsdQ09{M z_Qnn?)OIuf{sjxGr!KUXNc=+Kn^tAbqF`vjd@EF0wb+`!z`J;%Z~mg11&b=JP~+;b z)N>eD??RQV4>ft;J0{Tke}b0vuLrkWJ$Fu`^tsZ?6#J!wXHWd)1Iof zj+^T`8gwC5DyX?wHGH9ZTD)+P^i^P&xNJDtF+ykE24((|hqj+1p)~+JpMR2OTX{v+GP7ze+ISThr(M4cf4{u_AFuhpO43;pyY~M8+ zTL}|x{{#79zTVeIV+9B^Z$6_P${?1q|YclQlZY;K#a9~F)wq2fo5sPJip8otY7Mmm? z$5KiNOMb%!GokfI`bC&~kaiJvqqv>R#3T28o~a3i5yGUv$UxOJiBSeNTKGiQAE zR)}5V>9RElu3aPv{NokTN%hnC?RfWtn0&3pa_3gL3+8$z-kjZSUGbUA&cApvJ=OV_ z6D}pcE!#-^xA}$nwZHd4tmq7GD%`nuIz#S)Ev|)bZzQY2UAXxqpSxtkIG=mw`tftz zTXS4{Pj+w13AnfOyEiB3-a)vNUqAQz_zmPNbq^8_<+MubyC+U?&!hyOyRgFTt#B7m zLxnrrH}TpD8H%Z(mb}?EtaR^i_}n`kRqlSr)ox;&C6-$G zj^(6wUF#(Ia#Gijx`Na+mbU|>8YCQYRGZW_lKMdxsTU=cJhp@Z4jVp08h4l_IT_h!IzJMTa9a#l;%HS00R@HEa7*H(Ww3J zmNkX4KA^0EbC1V8kJ6&6{A}4JgH*fuTmvj6C=wS};CH)kaWo;`y z9&3en#M4*Y>AF&9Abm}?qz{_(%Sk_2{_)a>C~`CD3-AYd4Bq+?aGLAxcDg<_E-j#{ zr90BzXDM&rHOFITOL=zxf_DFCZqZ57+_`r8oGi=Q3GbILy{Aq8>Zy|6C+TG@W|96F zAFRkfiHF3vR;H&1r|Ye(bc88u8Oz#8S&u$s%%B)*Nr6(p`8@mdo5Nj!(d@C(9z zemZfNRMW5Sj4cFReoWFK#9dAp2Q zK;Iz0am<02jK)4c*&d4z;hQ_$u3o|G6FGQbqHD_O?wxLUrhBe?pL>pbz%7hamSqYb zAElmxYe!=Pgh}|A4u=>=$C3=SSnXslfM&j3HyZnrbfQD%sEloPzCGatW;Kttf}vw4 zp?MRX@17W20n*BpvY9&XMTU9_+?A`4-*)19@E-RKiGVIPJALkg4KAPCyFSag#a#ed zGr4IRdX%)sNP7^v*ZrRx$N9?CdDZXkcDRPp(~zQXY0o6e-54H?y)Sih6+l-d#D$UX z-V`3F==4MAs^8`MSBHC_tHwRREICN4hg@^q!~8~Et;8=R{#rr^!*v5;fM;hHH%xS{ z1%yoQt|pVfb)Snn=WL?pP}Uq%)?CV3%?rsZWk^}B=OyX2X;MlG@W$0aD3v&W$ju@m z+6h(GYbERT#4sI`WQcIs6{3T-SG|RoVIAv83Mt8R>jYWTPGb#V-ds%>D&-0Xa5Y z5N)@(5@VIz7UtiFo$ig!M)Csy%G>U|hO*~U_8r6n80y*PtTJsy4g|Hkon2{L=$q*J zA1-ork_(Pa&h7N6bAf1rOf_7hpVBw(3n zzmlsBuI+HS)}*I@_-xqW-sy5)2gW0u@*98x23=P|4MC_O03y*>O2~JSP6&gUN)f9N zjZkL0yd98ImL(M;bX&*UHS+fN<9S;<=Isje){+Av-)0;N501vpVomjt{n?u3veNfw z&P3N^;~@gXv;Ad~9= z2$i*tx3z})nBlXoLTV$)nsEUg~$RywcsYKyiA+TE|W9nxK1Wg?pvn-Q;t(U+J#N#OOQ!|7TWm$M@;S*XdyY zDY4iE@pXlgF%o=iUVKjQGyS;EOi%a7?pchgnwpp*S@-U6bdbI}ZO0MKo=!>(8+Sm- z84}N(C|{hI#Y7)K*L1fN$dLg?c+DVPp|1$Qt=|v zR+_Y;E%>mstW4tNepuRNlM6GhDZx{qf7TX zn0ikrca14mn&-OvqgrwOe^V=#B)4K`aw|S+s093|r_`{182Dva|DK_8O%n9A5hmS; zB*Q|W{Bc_GaYiHs7JvMEVDaCEw%h2Q=+EHZ(8&&dJDFlqX$Q%}AwXt@>bQoq%n=`& zRw3Nvzo&cuZ9^^dT70O}AdY46{I#UHoab*9{p+un~$9UlhY z`o9Cd_P8||_$nFZHU#0B#j)5Drcb#V_-!Swhq#mCI*c)E)5ID~=2YjrOtYCYy-?ss zHeN|R$EasYDf>5ZnKzw`ZT29B9Ims|ugfbYIu9fBqR`-X3^jhYlO+r?o*evL{%Pcc z>6lQl-q!NL7&#`82Y2*#CU zlhybNvdOAiMBgQdz9?@fWs<)c&TmX`7qF9qs;qM2ocR5`iF4!k0j1GRY!Q8sl!jI3OEU?E+-oeI{Q4s zV&p}T7e1&@bU`-J+AG>1)W`4vb{Z)ggds{@Xj(4Qq1NHP!(Mgw5_n%4TubN|4DX|) zXxi?gR6|WP2;UoWG!n|D~w^go22tdI*&+!W6;163?Fo?PRcKHI5<1V1glfZM(2$Z`DY@lh(vj%%B(c3 zy4o8YkGx!{`cbZLdN+=R&LH)(!wSsIG-N`Y8a;vi`S zN@%QAT0dz;3nS=)00dg}J0{W5cSN6t-Obea9IJS-(i5ohSMyR(bkeANosqO%WWD?w zchh`#`wi}OHK+(`l9a(BL5l1xOO~L!Dd29e(TPw=gBMz3oSJB5dWC|2A{qzu5FeTU zV^z|$#NEC`G#D9bLjxhYmHf|PlTjawiG7<~h4LdVMBH~J0uH|geuw@Boy6uWzvyqk z20QS*+%g?WMtbD7Vb-^qXsBD;kss}S3j$#J|ILpw_UtoVxTKRH{{mIYt=Ui!IB zWH*7!FQ{i^ODuMUfu+RlBW}{xSnQpoxMzvW{#q>dnu(MCju7|CU9s2$VqB@SU8 zo>jQ7=$pO0G>XV7Ws5NDT;}c{BGaI!PAW^$k(x&mbGF~z?p%|$C?o(G*Nv1l1$&<6 zxb8k7D<}dw$`x~mgYODi# zFRHvXUB^|~(CzqTzk;^QRPYBmJQ{R7M%=6D&`n@cH)#cRzrbp`9_*tERtq^sUwCHD9=E@~1 zNV!nmt81otFZvO=?Dy}E#@f`gsn1?}4q=BOm#A{(DlzZH%t)?9Svr(;v0P$%C6_G! zlP{CaTG^`aOgAmB$uH+Ze)2M8Zpn)%zM0NsP}e1O!5E6f^su1V+)+&)iG5jyvl^D zO?Z6S0>zJ!lz95XA>SV;ka{5{U-c^31^tF%7j;$aJ30RLbke|EdZ00&v@-<;XAFZC8KS=H4V?(&uuPb)6Du(V4(mEJzJq_|{Sk&gYS zS}?G*?scA+%4IpN2hzs7tl_lrSypx$M0Hsw#pyS>78lfQ(|KzAc+1BB)c9=6rkm9G zla<|Na-7_|tO;>CPJZW-6XM?F7=7>Jq_{V2{3%MmI5vk%PL7{DHdgBOST=u5e(Mq~ zoA*Qjxj0cibY8mnPgyh1PZxixW%JwA^7Ad5&!)zoW~HNZ7bnkczL=W+49hb3mKtAx zONDgpv1frqYQfPg>#bNKM&Ah=bpki9nWxlQLE?lDJAhA#fsZ{;NV0V0Tx7~wc`i3e zS1I>W{?;+^eiLuci*}Z4xN*R}?S4tSe`hHf}fB@f&r#I*Z2bJ$Cs5C@yv8jBuA-{&;S< z)Y&q^K@-0{} z=jF3Ze94&jB2!Mmm~y6>^yOpHmz(stW75wv=?llCzgorTTIHtw<))ot+ncVxtr_Ao z(M6Xk|5Mg&^Hb?G6CO(S>FQliIpXPJEMF2i(UFF4{8*(w^#pqPorxby7jnkffwVT3 zF9jGNXBz(eH0eJjbm7)`qR#)(!v8=(^orDG;4H0{>vhuSIZtf=aaE2^ll(92SIWD4&^Qq*Qh-T+!RbO(ec zN5;lp=c#zNwPR4HH|TC%m?3=)@pJCpt3OW-m#VPyxycAG7B7K zqec8C6JK+qE=Sp+5r3D7ANiUFm^v3o{I{gP&J*YH@0#=j%D=t#1w(S{hbms~Qm;o% zdh6%9UVEST2|NB@b-n6rA6XA(DCd3R1wJ)n;PYt^L&j_5A5Fh>V13TS(+Sleb=HQv zLKUCdMtPc*A^zG7@n6jl|IaGkZMFM#z3N;9<^OAj^uIOftsb3T*?5tDcZT#M#Cv%^ z_R0Zo^OEE%z@@G;ReXW9bPU`sF?c?7P}ghkIbW{g$Chqc3r+g=f6?P*pXIE}kp4?1 zeNC?}|7xAh>dlb;o5Xuhtk(KD@wsXE+wU`!^J<28*ZA~wI#tEHts$AXx!yNzxHLoh z#l)Xu(j*7%b~!)L<*0L{Bv_ZBoI5kb?=aEMS@R^lk=;ap~(hsV5x7Gce9(Q&2lzN6te1ElWk2*_3{IH2%sSdAM zmOB4T{78oKvr(|5n_te#5bw(nFaB#}yjK29x5u{O=``^pP8dFyveO{EmH1rXFv-9{ zz2t9$UC!A${rAj^EhfI^h=zkYtI4~soA|8(0|)q*T;Epl`ab#p=ftPO=LbzWLq~Ku z$~J|JkDB;_=XJg6ye;uhWGMf=4DsioSW5@zV21eXR6O%eyKc`C(}@V{41rtw7`QcN zDCaIy&JH7AebJ zi9;nWWhX^=z{IZ%>v&~HPW%fQ${#i9OJsq-WzgCh2ONZsn#R!4ISM{!oPbwF#HWKl z=F19iN7iUKC|?WIvn)gU+lfzyKVQp`{(qVBOa4u_U)c^){!i@qOLe?D-%0#0O}wr5 z_yTcq{ilhqiRyN$v)07#GV$IjU5>1C)RpXvvf3A%Ut4RnwTs)y&f*y*#nYx;* z2zQ3NaK>40H8gfKu4(SX=~iucZEbx^TWe#dRa@K8R=cL9ZB<=MZ9}-NqqDZIYn@f! zCf+H-jSa;!OJyUEJ;tbqztDdZCky% zrLC?Z(X?dmiEHa_z<;Ikk6CTI^z;+ zb#q5&xOm#MnKP}1j>eYu4!NI3AuWyVog^tMGf6HkOC;fbhKZg&Z6=M>Ik_*jbn!Dv zi>F^QeVWx$*IrkD1D@ZE1Gw7Ss)fGl%G%2Le$cJ9cFz1IwUq%A8SpQ(YUhL&RQN)* z3#zIXRW7bw?5hY>O2QNzXh@Cd4A*spty=%G`M&Dl>@gtgl-vekYHz~FCg?`~HLKe? z#9Lskav8W9tnO$8iEr*`4mXyUOlP+S4l0+n#b+O@S-3)Ip`QSp48;kNeL&TvO_ z>zb7G&82JW>YHjU+=F&DhIthVR?M!QT09kW6TDl~7_P-@U2V9D3L84h%NJDF)Rq>P z(8`wPRrR&?on4AHlB%k2YsE8ay2=_lZ?0>vwHnqmN*fc6>p&rmqtsgENwv04nvv*H zb4y)AOMP;3-HqCoMgd3j+LY9k-I1DBAk_fjx26KBc#U+g9so9jmbG1-3Z@NR^|c`Q zn#LR3FQ%By+W~_8S z*48z*roL9~YH0&OTH9Lba9g;owYk2w;T9TCnB4klphZjDn$<}KTwqrBTzql$Y~kUH>sGZiTD8Fiw5p-GRfes>$~=^C zxYmxf0H>v+txL5j3B9%FQ9XQ&rj6|y(*@}h$ll!8DDZ~qH_F%~6{4DHPc^BHtZk?Z z*J%|ena6bQRm^-KThf@SLQ}Ckwd{uaHihGO(!3d(PcXIBU9I)CVKt7> zS$MUeuFMRQ1^^mfo80JR1QgaIP3sf}QrpnkR@+q9+8{WQ#Of5ur-ClQt%NlT$~Ly% zM9mFt^ikT;vD);t6BgNWBF)<9akJu78a1ZUn9Rs`aZ;OZXTwey_1d`>F zkOD+z?$p}2PUZ_?t-_oVWip*XLP|hP0XP7xU)xSp5)}jd_FF*2L~fb)5DeFXT*z{3 zx^Uwiu5F%{QqsD{4&(&7(^M)*3@~m47>P2Z1>|MYOd@faTLjk#H7J-wT;4XlIstr;|gQM%cS(Fc#%?nVlah#wNN5}Y`=wM29Tw2TOlMH znISBhYXHycupo;dcr6O@&Rf<({)FKU9X8o_+U>ek%na06yr#9QcvV+(OT&fDuy_^a zs|a2gu3G~Xc-K_d*<=+nNl~5-!yWp~O^qGmay{jtmUoDKb&|o{wYP+=V#N)LxdpO3 zhQTJQScH8NwJCTOH#QmZzNvvi>?fU7%lSHoeQ)MX+9bnK4DndSf=XbJS<3wH1Y$2E zD<*qcWbeb+w=$+ma<>y!|CwtrE8v*kLL}t*PK-=eO-`t|DHt z*!A1?1a@fK36VryW8t@gSh2ye^V@a@cGzI@+3mN}+2IYm7n>gY*|txx!y%Jj+Am$P z+i#++TTQ&3-?lTd!+w*{uHVjY_rJ&FuQ2IsyCpmH8u&^6)A^0fzlAt~iL_5$-qcX= zGx;*b#iRPTOV020>Q{Cs`+Uh)u6eM-uk)Oof8-pUzz*&9+GW_!cK9!2^4od|JM0x_ zut}F)uO0QT+$7g;+ilpPZSQ8MAKU*Qn*8xvZ2Jxq+IVQ^_u4lm{5hf2Z|Ar7TkUYM z{lcUlTmOAy^4sS z`7!gqNM6A`JHNdjTyFAvP5*8DwClCUaT|FBes+G_o@M0<9kX3tCS7)ZJA9pY$@$~^ z$SZaJvHaK0XBRobjl|jYdyT$tlF46VCp6*M{O=Mk^_PrEXXh^(6K{7XIUIu`Do4Q7 zztt!eg^mOK?D}o~aWZjs+f_#MH`t+L_X%@Oy6k%GC^@d0F8}u1b?m5}(1c_2|9@m0 B&UXL+ literal 0 HcmV?d00001 diff --git a/src/blas.f b/src/dependencies/blas.f similarity index 100% rename from src/blas.f rename to src/dependencies/blas.f diff --git a/src/lapack.f b/src/dependencies/lapack.f similarity index 100% rename from src/lapack.f rename to src/dependencies/lapack.f diff --git a/src/dependencies/slatec.f b/src/dependencies/slatec.f new file mode 100644 index 0000000..c652a26 --- /dev/null +++ b/src/dependencies/slatec.f @@ -0,0 +1,5023 @@ +*DECK DLSEI + SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, + + RNORML, MODE, WS, IP) +C***BEGIN PROLOGUE DLSEI +C***PURPOSE Solve a linearly constrained least squares problem with +C equality and inequality constraints, and optionally compute +C a covariance matrix. +C***LIBRARY SLATEC +C***CATEGORY K1A2A, D9 +C***TYPE DOUBLE PRECISION (LSEI-S, DLSEI-D) +C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, +C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, +C QUADRATIC PROGRAMMING +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C Abstract +C +C This subprogram solves a linearly constrained least squares +C problem with both equality and inequality constraints, and, if the +C user requests, obtains a covariance matrix of the solution +C parameters. +C +C Suppose there are given matrices E, A and G of respective +C dimensions ME by N, MA by N and MG by N, and vectors F, B and H of +C respective lengths ME, MA and MG. This subroutine solves the +C linearly constrained least squares problem +C +C EX = F, (E ME by N) (equations to be exactly +C satisfied) +C AX = B, (A MA by N) (equations to be +C approximately satisfied, +C least squares sense) +C GX .GE. H,(G MG by N) (inequality constraints) +C +C The inequalities GX .GE. H mean that every component of the +C product GX must be .GE. the corresponding component of H. +C +C In case the equality constraints cannot be satisfied, a +C generalized inverse solution residual vector length is obtained +C for F-EX. This is the minimal length possible for F-EX. +C +C Any values ME .GE. 0, MA .GE. 0, or MG .GE. 0 are permitted. The +C rank of the matrix E is estimated during the computation. We call +C this value KRANKE. It is an output parameter in IP(1) defined +C below. Using a generalized inverse solution of EX=F, a reduced +C least squares problem with inequality constraints is obtained. +C The tolerances used in these tests for determining the rank +C of E and the rank of the reduced least squares problem are +C given in Sandia Tech. Rept. SAND-78-1290. They can be +C modified by the user if new values are provided in +C the option list of the array PRGOPT(*). +C +C The user must dimension all arrays appearing in the call list.. +C W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2) +C where K=MAX(MA+MG,N). This allows for a solution of a range of +C problems in the given working space. The dimension of WS(*) +C given is a necessary overestimate. Once a particular problem +C has been run, the output parameter IP(3) gives the actual +C dimension required for that problem. +C +C The parameters for DLSEI( ) are +C +C Input.. All TYPE REAL variables are DOUBLE PRECISION +C +C W(*,*),MDW, The array W(*,*) is doubly subscripted with +C ME,MA,MG,N first dimensioning parameter equal to MDW. +C For this discussion let us call M = ME+MA+MG. Then +C MDW must satisfy MDW .GE. M. The condition +C MDW .LT. M is an error. +C +C The array W(*,*) contains the matrices and vectors +C +C (E F) +C (A B) +C (G H) +C +C in rows and columns 1,...,M and 1,...,N+1 +C respectively. +C +C The integers ME, MA, and MG are the +C respective matrix row dimensions +C of E, A and G. Each matrix has N columns. +C +C PRGOPT(*) This real-valued array is the option vector. +C If the user is satisfied with the nominal +C subprogram features set +C +C PRGOPT(1)=1 (or PRGOPT(1)=1.0) +C +C Otherwise PRGOPT(*) is a linked list consisting of +C groups of data of the following form +C +C LINK +C KEY +C DATA SET +C +C The parameters LINK and KEY are each one word. +C The DATA SET can be comprised of several words. +C The number of items depends on the value of KEY. +C The value of LINK points to the first +C entry of the next group of data within +C PRGOPT(*). The exception is when there are +C no more options to change. In that +C case, LINK=1 and the values KEY and DATA SET +C are not referenced. The general layout of +C PRGOPT(*) is as follows. +C +C ...PRGOPT(1) = LINK1 (link to first entry of next group) +C . PRGOPT(2) = KEY1 (key to the option change) +C . PRGOPT(3) = data value (data value for this change) +C . . +C . . +C . . +C ...PRGOPT(LINK1) = LINK2 (link to the first entry of +C . next group) +C . PRGOPT(LINK1+1) = KEY2 (key to the option change) +C . PRGOPT(LINK1+2) = data value +C ... . +C . . +C . . +C ...PRGOPT(LINK) = 1 (no more options to change) +C +C Values of LINK that are nonpositive are errors. +C A value of LINK .GT. NLINK=100000 is also an error. +C This helps prevent using invalid but positive +C values of LINK that will probably extend +C beyond the program limits of PRGOPT(*). +C Unrecognized values of KEY are ignored. The +C order of the options is arbitrary and any number +C of options can be changed with the following +C restriction. To prevent cycling in the +C processing of the option array, a count of the +C number of options changed is maintained. +C Whenever this count exceeds NOPT=1000, an error +C message is printed and the subprogram returns. +C +C Options.. +C +C KEY=1 +C Compute in W(*,*) the N by N +C covariance matrix of the solution variables +C as an output parameter. Nominally the +C covariance matrix will not be computed. +C (This requires no user input.) +C The data set for this option is a single value. +C It must be nonzero when the covariance matrix +C is desired. If it is zero, the covariance +C matrix is not computed. When the covariance matrix +C is computed, the first dimensioning parameter +C of the array W(*,*) must satisfy MDW .GE. MAX(M,N). +C +C KEY=10 +C Suppress scaling of the inverse of the +C normal matrix by the scale factor RNORM**2/ +C MAX(1, no. of degrees of freedom). This option +C only applies when the option for computing the +C covariance matrix (KEY=1) is used. With KEY=1 and +C KEY=10 used as options the unscaled inverse of the +C normal matrix is returned in W(*,*). +C The data set for this option is a single value. +C When it is nonzero no scaling is done. When it is +C zero scaling is done. The nominal case is to do +C scaling so if option (KEY=1) is used alone, the +C matrix will be scaled on output. +C +C KEY=2 +C Scale the nonzero columns of the +C entire data matrix. +C (E) +C (A) +C (G) +C +C to have length one. The data set for this +C option is a single value. It must be +C nonzero if unit length column scaling +C is desired. +C +C KEY=3 +C Scale columns of the entire data matrix +C (E) +C (A) +C (G) +C +C with a user-provided diagonal matrix. +C The data set for this option consists +C of the N diagonal scaling factors, one for +C each matrix column. +C +C KEY=4 +C Change the rank determination tolerance for +C the equality constraint equations from +C the nominal value of SQRT(DRELPR). This quantity can +C be no smaller than DRELPR, the arithmetic- +C storage precision. The quantity DRELPR is the +C largest positive number such that T=1.+DRELPR +C satisfies T .EQ. 1. The quantity used +C here is internally restricted to be at +C least DRELPR. The data set for this option +C is the new tolerance. +C +C KEY=5 +C Change the rank determination tolerance for +C the reduced least squares equations from +C the nominal value of SQRT(DRELPR). This quantity can +C be no smaller than DRELPR, the arithmetic- +C storage precision. The quantity used +C here is internally restricted to be at +C least DRELPR. The data set for this option +C is the new tolerance. +C +C For example, suppose we want to change +C the tolerance for the reduced least squares +C problem, compute the covariance matrix of +C the solution parameters, and provide +C column scaling for the data matrix. For +C these options the dimension of PRGOPT(*) +C must be at least N+9. The Fortran statements +C defining these options would be as follows: +C +C PRGOPT(1)=4 (link to entry 4 in PRGOPT(*)) +C PRGOPT(2)=1 (covariance matrix key) +C PRGOPT(3)=1 (covariance matrix wanted) +C +C PRGOPT(4)=7 (link to entry 7 in PRGOPT(*)) +C PRGOPT(5)=5 (least squares equas. tolerance key) +C PRGOPT(6)=... (new value of the tolerance) +C +C PRGOPT(7)=N+9 (link to entry N+9 in PRGOPT(*)) +C PRGOPT(8)=3 (user-provided column scaling key) +C +C CALL DCOPY (N, D, 1, PRGOPT(9), 1) (Copy the N +C scaling factors from the user array D(*) +C to PRGOPT(9)-PRGOPT(N+8)) +C +C PRGOPT(N+9)=1 (no more options to change) +C +C The contents of PRGOPT(*) are not modified +C by the subprogram. +C The options for WNNLS( ) can also be included +C in this array. The values of KEY recognized +C by WNNLS( ) are 6, 7 and 8. Their functions +C are documented in the usage instructions for +C subroutine WNNLS( ). Normally these options +C do not need to be modified when using DLSEI( ). +C +C IP(1), The amounts of working storage actually +C IP(2) allocated for the working arrays WS(*) and +C IP(*), respectively. These quantities are +C compared with the actual amounts of storage +C needed by DLSEI( ). Insufficient storage +C allocated for either WS(*) or IP(*) is an +C error. This feature was included in DLSEI( ) +C because miscalculating the storage formulas +C for WS(*) and IP(*) might very well lead to +C subtle and hard-to-find execution errors. +C +C The length of WS(*) must be at least +C +C LW = 2*(ME+N)+K+(MG+2)*(N+7) +C +C where K = max(MA+MG,N) +C This test will not be made if IP(1).LE.0. +C +C The length of IP(*) must be at least +C +C LIP = MG+2*N+2 +C This test will not be made if IP(2).LE.0. +C +C Output.. All TYPE REAL variables are DOUBLE PRECISION +C +C X(*),RNORME, The array X(*) contains the solution parameters +C RNORML if the integer output flag MODE = 0 or 1. +C The definition of MODE is given directly below. +C When MODE = 0 or 1, RNORME and RNORML +C respectively contain the residual vector +C Euclidean lengths of F - EX and B - AX. When +C MODE=1 the equality constraint equations EX=F +C are contradictory, so RNORME .NE. 0. The residual +C vector F-EX has minimal Euclidean length. For +C MODE .GE. 2, none of these parameters is defined. +C +C MODE Integer flag that indicates the subprogram +C status after completion. If MODE .GE. 2, no +C solution has been computed. +C +C MODE = +C +C 0 Both equality and inequality constraints +C are compatible and have been satisfied. +C +C 1 Equality constraints are contradictory. +C A generalized inverse solution of EX=F was used +C to minimize the residual vector length F-EX. +C In this sense, the solution is still meaningful. +C +C 2 Inequality constraints are contradictory. +C +C 3 Both equality and inequality constraints +C are contradictory. +C +C The following interpretation of +C MODE=1,2 or 3 must be made. The +C sets consisting of all solutions +C of the equality constraints EX=F +C and all vectors satisfying GX .GE. H +C have no points in common. (In +C particular this does not say that +C each individual set has no points +C at all, although this could be the +C case.) +C +C 4 Usage error occurred. The value +C of MDW is .LT. ME+MA+MG, MDW is +C .LT. N and a covariance matrix is +C requested, or the option vector +C PRGOPT(*) is not properly defined, +C or the lengths of the working arrays +C WS(*) and IP(*), when specified in +C IP(1) and IP(2) respectively, are not +C long enough. +C +C W(*,*) The array W(*,*) contains the N by N symmetric +C covariance matrix of the solution parameters, +C provided this was requested on input with +C the option vector PRGOPT(*) and the output +C flag is returned with MODE = 0 or 1. +C +C IP(*) The integer working array has three entries +C that provide rank and working array length +C information after completion. +C +C IP(1) = rank of equality constraint +C matrix. Define this quantity +C as KRANKE. +C +C IP(2) = rank of reduced least squares +C problem. +C +C IP(3) = the amount of storage in the +C working array WS(*) that was +C actually used by the subprogram. +C The formula given above for the length +C of WS(*) is a necessary overestimate. +C If exactly the same problem matrices +C are used in subsequent executions, +C the declared dimension of WS(*) can +C be reduced to this output value. +C User Designated +C Working Arrays.. +C +C WS(*),IP(*) These are respectively type real +C and type integer working arrays. +C Their required minimal lengths are +C given above. +C +C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for +C linear least squares problems with equality and +C nonnegativity constraints, Report SAND77-0552, Sandia +C Laboratories, June 1978. +C K. H. Haskell and R. J. Hanson, Selected algorithms for +C the linearly constrained least squares problem - a +C users guide, Report SAND78-1290, Sandia Laboratories, +C August 1979. +C K. H. Haskell and R. J. Hanson, An algorithm for +C linear least squares problems with equality and +C nonnegativity constraints, Mathematical Programming +C 21 (1981), pp. 98-118. +C R. J. Hanson and K. H. Haskell, Two algorithms for the +C linearly constrained least squares problem, ACM +C Transactions on Mathematical Software, September 1982. +C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, +C DNRM2, DSCAL, DSWAP, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and extensively revised (WRB & RWC) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900510 Convert XERRWV calls to XERMSG calls. (RWC) +C 900604 DP version created from SP version. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C 180613 Removed prints and replaced DP --> DOUBLE PRECISION. (THC) +C***END PROLOGUE DLSEI + + INTEGER IP(3), MA, MDW, ME, MG, MODE, N + DOUBLE PRECISION PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*) +C + EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, DNRM2, + * DSCAL, DSWAP + DOUBLE PRECISION D1MACH, DASUM, DDOT, DNRM2 +C + DOUBLE PRECISION DRELPR, ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, + * SN, SNMAX, T, TAU, UJ, UP, VJ, XNORM, XNRME + INTEGER I, IMAX, J, JP1, K, KEY, KRANKE, LAST, LCHK, LINK, M, + * MAPKE1, MDEQC, MEND, MEP1, N1, N2, NEXT, NLINK, NOPT, NP1, + * NTIMES + LOGICAL COV, FIRST +C CHARACTER*8 XERN1, XERN2, XERN3, XERN4 + SAVE FIRST, DRELPR +C + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DLSEI +C +C Set the nominal tolerance used in the code for the equality +C constraint equations. +C + IF (FIRST) DRELPR = D1MACH(4) + FIRST = .FALSE. + TAU = SQRT(DRELPR) +C +C Check that enough storage was allocated in WS(*) and IP(*). +C + MODE = 4 + IF (MIN(N,ME,MA,MG) .LT. 0) THEN +C WRITE (XERN1, '(I8)') N +C WRITE (XERN2, '(I8)') ME +C WRITE (XERN3, '(I8)') MA +C WRITE (XERN4, '(I8)') MG +C CALL XERMSG ('SLATEC', 'LSEI', 'ALL OF THE VARIABLES N, ME,' // +C * ' MA, MG MUST BE .GE. 0$$ENTERED ROUTINE WITH' // +C * '$$N = ' // XERN1 // +C * '$$ME = ' // XERN2 // +C * '$$MA = ' // XERN3 // +C * '$$MG = ' // XERN4, 2, 1) + RETURN + ENDIF +C + IF (IP(1).GT.0) THEN + LCHK = 2*(ME+N) + MAX(MA+MG,N) + (MG+2)*(N+7) + IF (IP(1).LT.LCHK) THEN +C WRITE (XERN1, '(I8)') LCHK +C CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // +C * 'ALLOCATED FOR WS(*), NEED LW = ' // XERN1, 2, 1) + RETURN + ENDIF + ENDIF +C + IF (IP(2).GT.0) THEN + LCHK = MG + 2*N + 2 + IF (IP(2).LT.LCHK) THEN +C WRITE (XERN1, '(I8)') LCHK +C CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // +C * 'ALLOCATED FOR IP(*), NEED LIP = ' // XERN1, 2, 1) + RETURN + ENDIF + ENDIF +C +C Compute number of possible right multiplying Householder +C transformations. +C + M = ME + MA + MG + IF (N.LE.0 .OR. M.LE.0) THEN + MODE = 0 + RNORME = 0 + RNORML = 0 + RETURN + ENDIF +C + IF (MDW.LT.M) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', 'MDW.LT.ME+MA+MG IS AN ERROR', +C + 2, 1) + RETURN + ENDIF +C + NP1 = N + 1 + KRANKE = MIN(ME,N) + N1 = 2*KRANKE + 1 + N2 = N1 + N +C +C Set nominal values. +C +C The nominal column scaling used in the code is +C the identity scaling. +C + CALL DCOPY (N, 1.D0, 0, WS(N1), 1) +C +C No covariance matrix is nominally computed. +C + COV = .FALSE. +C +C Process option vector. +C Define bound for number of options to change. +C + NOPT = 1000 + NTIMES = 0 +C +C Define bound for positive values of LINK. +C + NLINK = 100000 + LAST = 1 + LINK = PRGOPT(1) + IF (LINK.EQ.0 .OR. LINK.GT.NLINK) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', +C + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) + RETURN + ENDIF +C + 100 IF (LINK.GT.1) THEN + NTIMES = NTIMES + 1 + IF (NTIMES.GT.NOPT) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', +C + 'THE LINKS IN THE OPTION VECTOR ARE CYCLING.', 2, 1) + RETURN + ENDIF +C + KEY = PRGOPT(LAST+1) + IF (KEY.EQ.1) THEN + COV = PRGOPT(LAST+2) .NE. 0.D0 + ELSEIF (KEY.EQ.2 .AND. PRGOPT(LAST+2).NE.0.D0) THEN + DO 110 J = 1,N + T = DNRM2(M,W(1,J),1) + IF (T.NE.0.D0) T = 1.D0/T + WS(J+N1-1) = T + 110 CONTINUE + ELSEIF (KEY.EQ.3) THEN + CALL DCOPY (N, PRGOPT(LAST+2), 1, WS(N1), 1) + ELSEIF (KEY.EQ.4) THEN + TAU = MAX(DRELPR,PRGOPT(LAST+2)) + ENDIF +C + NEXT = PRGOPT(LINK) + IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', +C + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) + RETURN + ENDIF +C + LAST = LINK + LINK = NEXT + GO TO 100 + ENDIF +C + DO 120 J = 1,N + CALL DSCAL (M, WS(N1+J-1), W(1,J), 1) + 120 CONTINUE +C + IF (COV .AND. MDW.LT.N) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', +C + 'MDW .LT. N WHEN COV MATRIX NEEDED, IS AN ERROR', 2, 1) + RETURN + ENDIF +C +C Problem definition and option vector OK. +C + MODE = 0 +C +C Compute norm of equality constraint matrix and right side. +C + ENORM = 0.D0 + DO 130 J = 1,N + ENORM = MAX(ENORM,DASUM(ME,W(1,J),1)) + 130 CONTINUE +C + FNORM = DASUM(ME,W(1,NP1),1) + SNMAX = 0.D0 + RNMAX = 0.D0 + DO 150 I = 1,KRANKE +C +C Compute maximum ratio of vector lengths. Partition is at +C column I. +C + DO 140 K = I,ME + SN = DDOT(N-I+1,W(K,I),MDW,W(K,I),MDW) + RN = DDOT(I-1,W(K,1),MDW,W(K,1),MDW) + IF (RN.EQ.0.D0 .AND. SN.GT.SNMAX) THEN + SNMAX = SN + IMAX = K + ELSEIF (K.EQ.I .OR. SN*RNMAX.GT.RN*SNMAX) THEN + SNMAX = SN + RNMAX = RN + IMAX = K + ENDIF + 140 CONTINUE +C +C Interchange rows if necessary. +C + IF (I.NE.IMAX) CALL DSWAP (NP1, W(I,1), MDW, W(IMAX,1), MDW) + IF (SNMAX.GT.RNMAX*TAU**2) THEN +C +C Eliminate elements I+1,...,N in row I. +C + CALL DH12 (1, I, I+1, N, W(I,1), MDW, WS(I), W(I+1,1), MDW, + + 1, M-I) + ELSE + KRANKE = I - 1 + GO TO 160 + ENDIF + 150 CONTINUE +C +C Save diagonal terms of lower trapezoidal matrix. +C + 160 CALL DCOPY (KRANKE, W, MDW+1, WS(KRANKE+1), 1) +C +C Use Householder transformation from left to achieve +C KRANKE by KRANKE upper triangular form. +C + IF (KRANKE.LT.ME) THEN + DO 170 K = KRANKE,1,-1 +C +C Apply transformation to matrix cols. 1,...,K-1. +C + CALL DH12 (1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, + * K-1) +C +C Apply to rt side vector. +C + CALL DH12 (2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, + + 1, 1) + 170 CONTINUE + ENDIF +C +C Solve for variables 1,...,KRANKE in new coordinates. +C + CALL DCOPY (KRANKE, W(1, NP1), 1, X, 1) + DO 180 I = 1,KRANKE + X(I) = (X(I)-DDOT(I-1,W(I,1),MDW,X,1))/W(I,I) + 180 CONTINUE +C +C Compute residuals for reduced problem. +C + MEP1 = ME + 1 + RNORML = 0.D0 + DO 190 I = MEP1,M + W(I,NP1) = W(I,NP1) - DDOT(KRANKE,W(I,1),MDW,X,1) + SN = DDOT(KRANKE,W(I,1),MDW,W(I,1),MDW) + RN = DDOT(N-KRANKE,W(I,KRANKE+1),MDW,W(I,KRANKE+1),MDW) + IF (RN.LE.SN*TAU**2 .AND. KRANKE.LT.N) + * CALL DCOPY (N-KRANKE, 0.D0, 0, W(I,KRANKE+1), MDW) + 190 CONTINUE +C +C Compute equality constraint equations residual length. +C + RNORME = DNRM2(ME-KRANKE,W(KRANKE+1,NP1),1) +C +C Move reduced problem data upward if KRANKE.LT.ME. +C + IF (KRANKE.LT.ME) THEN + DO 200 J = 1,NP1 + CALL DCOPY (M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1) + 200 CONTINUE + ENDIF +C +C Compute solution of reduced problem. +C + CALL DLSI(W(KRANKE+1, KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT, + + X(KRANKE+1), RNORML, MODE, WS(N2), IP(2)) +C +C Test for consistency of equality constraints. +C + IF (ME.GT.0) THEN + MDEQC = 0 + XNRME = DASUM(KRANKE,W(1,NP1),1) + IF (RNORME.GT.TAU*(ENORM*XNRME+FNORM)) MDEQC = 1 + MODE = MODE + MDEQC +C +C Check if solution to equality constraints satisfies inequality +C constraints when there are no degrees of freedom left. +C + IF (KRANKE.EQ.N .AND. MG.GT.0) THEN + XNORM = DASUM(N,X,1) + MAPKE1 = MA + KRANKE + 1 + MEND = MA + KRANKE + MG + DO 210 I = MAPKE1,MEND + SIZE = DASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1)) + IF (W(I,NP1).GT.TAU*SIZE) THEN + MODE = MODE + 2 + GO TO 290 + ENDIF + 210 CONTINUE + ENDIF + ENDIF +C +C Replace diagonal terms of lower trapezoidal matrix. +C + IF (KRANKE.GT.0) THEN + CALL DCOPY (KRANKE, WS(KRANKE+1), 1, W, MDW+1) +C +C Reapply transformation to put solution in original coordinates. +C + DO 220 I = KRANKE,1,-1 + CALL DH12 (2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1) + 220 CONTINUE +C +C Compute covariance matrix of equality constrained problem. +C + IF (COV) THEN + DO 270 J = MIN(KRANKE,N-1),1,-1 + RB = WS(J)*W(J,J) + IF (RB.NE.0.D0) RB = 1.D0/RB + JP1 = J + 1 + DO 230 I = JP1,N + W(I,J) = RB*DDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW) + 230 CONTINUE +C + GAM = 0.5D0*RB*DDOT(N-J,W(JP1,J),1,W(J,JP1),MDW) + CALL DAXPY (N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1) + DO 250 I = JP1,N + DO 240 K = I,N + W(I,K) = W(I,K) + W(J,I)*W(K,J) + W(I,J)*W(J,K) + W(K,I) = W(I,K) + 240 CONTINUE + 250 CONTINUE + UJ = WS(J) + VJ = GAM*UJ + W(J,J) = UJ*VJ + UJ*VJ + DO 260 I = JP1,N + W(J,I) = UJ*W(I,J) + VJ*W(J,I) + 260 CONTINUE + CALL DCOPY (N-J, W(J, JP1), MDW, W(JP1,J), 1) + 270 CONTINUE + ENDIF + ENDIF +C +C Apply the scaling to the covariance matrix. +C + IF (COV) THEN + DO 280 I = 1,N + CALL DSCAL (N, WS(I+N1-1), W(I,1), MDW) + CALL DSCAL (N, WS(I+N1-1), W(1,I), 1) + 280 CONTINUE + ENDIF +C +C Rescale solution vector. +C + 290 IF (MODE.LE.1) THEN + DO 300 J = 1,N + X(J) = X(J)*WS(N1+J-1) + 300 CONTINUE + ENDIF +C + IP(1) = KRANKE + IP(3) = IP(3) + 2*KRANKE + N + RETURN + END +*DECK DLSI + SUBROUTINE DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, + + IP) +C***BEGIN PROLOGUE DLSI +C***SUBSIDIARY +C***PURPOSE Subsidiary to DLSEI +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (LSI-S, DLSI-D) +C***AUTHOR Hanson, R. J., (SNLA) +C***DESCRIPTION +C +C This is a companion subprogram to DLSEI. The documentation for +C DLSEI has complete usage instructions. +C +C Solve.. +C AX = B, A MA by N (least squares equations) +C subject to.. +C +C GX.GE.H, G MG by N (inequality constraints) +C +C Input.. +C +C W(*,*) contains (A B) in rows 1,...,MA+MG, cols 1,...,N+1. +C (G H) +C +C MDW,MA,MG,N +C contain (resp) var. dimension of W(*,*), +C and matrix dimensions. +C +C PRGOPT(*), +C Program option vector. +C +C OUTPUT.. +C +C X(*),RNORM +C +C Solution vector(unless MODE=2), length of AX-B. +C +C MODE +C =0 Inequality constraints are compatible. +C =2 Inequality constraints contradictory. +C +C WS(*), +C Working storage of dimension K+N+(MG+2)*(N+7), +C where K=MAX(MA+MG,N). +C IP(MG+2*N+1) +C Integer working storage +C +C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, +C DLPDP, DSCAL, DSWAP +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and extensively revised (WRB & RWC) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900604 DP version created from SP version. (RWC) +C 920422 Changed CALL to DHFTI to include variable MA. (WRB) +C***END PROLOGUE DLSI + + INTEGER IP(*), MA, MDW, MG, MODE, N + DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*) +C + EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, DLPDP, + * DSCAL, DSWAP + DOUBLE PRECISION D1MACH, DASUM, DDOT +C + DOUBLE PRECISION ANORM, DRELPR, FAC, GAM, RB, TAU, TOL, XNORM, + * TMP_NORM(1) + INTEGER I, J, K, KEY, KRANK, KRM1, KRP1, L, LAST, LINK, M, MAP1, + * MDLPDP, MINMAN, N1, N2, N3, NEXT, NP1 + LOGICAL COV, FIRST, SCLCOV +C + SAVE DRELPR, FIRST + DATA FIRST /.TRUE./ +C +C***FIRST EXECUTABLE STATEMENT DLSI +C +C Set the nominal tolerance used in the code. +C + IF (FIRST) DRELPR = D1MACH(4) + FIRST = .FALSE. + TOL = SQRT(DRELPR) +C + MODE = 0 + RNORM = 0.D0 + M = MA + MG + NP1 = N + 1 + KRANK = 0 + IF (N.LE.0 .OR. M.LE.0) GO TO 370 +C +C To process option vector. +C + COV = .FALSE. + SCLCOV = .TRUE. + LAST = 1 + LINK = PRGOPT(1) +C + 100 IF (LINK.GT.1) THEN + KEY = PRGOPT(LAST+1) + IF (KEY.EQ.1) COV = PRGOPT(LAST+2) .NE. 0.D0 + IF (KEY.EQ.10) SCLCOV = PRGOPT(LAST+2) .EQ. 0.D0 + IF (KEY.EQ.5) TOL = MAX(DRELPR,PRGOPT(LAST+2)) + NEXT = PRGOPT(LINK) + LAST = LINK + LINK = NEXT + GO TO 100 + ENDIF +C +C Compute matrix norm of least squares equations. +C + ANORM = 0.D0 + DO 110 J = 1,N + ANORM = MAX(ANORM,DASUM(MA,W(1,J),1)) + 110 CONTINUE +C +C Set tolerance for DHFTI( ) rank test. +C + TAU = TOL*ANORM +C +C Compute Householder orthogonal decomposition of matrix. +C + CALL DCOPY (N, 0.D0, 0, WS, 1) + CALL DCOPY (MA, W(1, NP1), 1, WS, 1) + K = MAX(M,N) + MINMAN = MIN(MA,N) + N1 = K + 1 + N2 = N1 + N + CALL DHFTI (W, MDW, MA, N, WS, MA, 1, TAU, KRANK, TMP_NORM, + + WS(N2), WS(N1), IP) + RNORM = TMP_NORM(1) + FAC = 1.D0 + GAM = MA - KRANK + IF (KRANK.LT.MA .AND. SCLCOV) FAC = RNORM**2/GAM +C +C Reduce to DLPDP and solve. +C + MAP1 = MA + 1 +C +C Compute inequality rt-hand side for DLPDP. +C + IF (MA.LT.M) THEN + IF (MINMAN.GT.0) THEN + DO 120 I = MAP1,M + W(I,NP1) = W(I,NP1) - DDOT(N,W(I,1),MDW,WS,1) + 120 CONTINUE +C +C Apply permutations to col. of inequality constraint matrix. +C + DO 130 I = 1,MINMAN + CALL DSWAP (MG, W(MAP1,I), 1, W(MAP1,IP(I)), 1) + 130 CONTINUE +C +C Apply Householder transformations to constraint matrix. +C + IF (KRANK.GT.0 .AND. KRANK.LT.N) THEN + DO 140 I = KRANK,1,-1 + CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), + + W(MAP1,1), MDW, 1, MG) + 140 CONTINUE + ENDIF +C +C Compute permuted inequality constraint matrix times r-inv. +C + DO 160 I = MAP1,M + DO 150 J = 1,KRANK + W(I,J) = (W(I,J)-DDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J) + 150 CONTINUE + 160 CONTINUE + ENDIF +C +C Solve the reduced problem with DLPDP algorithm, +C the least projected distance problem. +C + CALL DLPDP(W(MAP1,1), MDW, MG, KRANK, N-KRANK, PRGOPT, X, + + XNORM, MDLPDP, WS(N2), IP(N+1)) +C +C Compute solution in original coordinates. +C + IF (MDLPDP.EQ.1) THEN + DO 170 I = KRANK,1,-1 + X(I) = (X(I)-DDOT(KRANK-I,W(I,I+1),MDW,X(I+1),1))/W(I,I) + 170 CONTINUE +C +C Apply Householder transformation to solution vector. +C + IF (KRANK.LT.N) THEN + DO 180 I = 1,KRANK + CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), + + X, 1, 1, 1) + 180 CONTINUE + ENDIF +C +C Repermute variables to their input order. +C + IF (MINMAN.GT.0) THEN + DO 190 I = MINMAN,1,-1 + CALL DSWAP (1, X(I), 1, X(IP(I)), 1) + 190 CONTINUE +C +C Variables are now in original coordinates. +C Add solution of unconstrained problem. +C + DO 200 I = 1,N + X(I) = X(I) + WS(I) + 200 CONTINUE +C +C Compute the residual vector norm. +C + RNORM = SQRT(RNORM**2+XNORM**2) + ENDIF + ELSE + MODE = 2 + ENDIF + ELSE + CALL DCOPY (N, WS, 1, X, 1) + ENDIF +C +C Compute covariance matrix based on the orthogonal decomposition +C from DHFTI( ). +C + IF (.NOT.COV .OR. KRANK.LE.0) GO TO 370 + KRM1 = KRANK - 1 + KRP1 = KRANK + 1 +C +C Copy diagonal terms to working array. +C + CALL DCOPY (KRANK, W, MDW+1, WS(N2), 1) +C +C Reciprocate diagonal terms. +C + DO 210 J = 1,KRANK + W(J,J) = 1.D0/W(J,J) + 210 CONTINUE +C +C Invert the upper triangular QR factor on itself. +C + IF (KRANK.GT.1) THEN + DO 230 I = 1,KRM1 + DO 220 J = I+1,KRANK + W(I,J) = -DDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J) + 220 CONTINUE + 230 CONTINUE + ENDIF +C +C Compute the inverted factor times its transpose. +C + DO 250 I = 1,KRANK + DO 240 J = I,KRANK + W(I,J) = DDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW) + 240 CONTINUE + 250 CONTINUE +C +C Zero out lower trapezoidal part. +C Copy upper triangular to lower triangular part. +C + IF (KRANK.LT.N) THEN + DO 260 J = 1,KRANK + CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) + 260 CONTINUE +C + DO 270 I = KRP1,N + CALL DCOPY (I, 0.D0, 0, W(I,1), MDW) + 270 CONTINUE +C +C Apply right side transformations to lower triangle. +C + N3 = N2 + KRP1 + DO 330 I = 1,KRANK + L = N1 + I + K = N2 + I + RB = WS(L-1)*WS(K-1) +C +C If RB.GE.0.D0, transformation can be regarded as zero. +C + IF (RB.LT.0.D0) THEN + RB = 1.D0/RB +C +C Store unscaled rank one Householder update in work array. +C + CALL DCOPY (N, 0.D0, 0, WS(N3), 1) + L = N1 + I + K = N3 + I + WS(K-1) = WS(L-1) +C + DO 280 J = KRP1,N + WS(N3+J-1) = W(I,J) + 280 CONTINUE +C + DO 290 J = 1,N + WS(J) = RB*(DDOT(J-I,W(J,I),MDW,WS(N3+I-1),1)+ + + DDOT(N-J+1,W(J,J),1,WS(N3+J-1),1)) + 290 CONTINUE +C + L = N3 + I + GAM = 0.5D0*RB*DDOT(N-I+1,WS(L-1),1,WS(I),1) + CALL DAXPY (N-I+1, GAM, WS(L-1), 1, WS(I), 1) + DO 320 J = I,N + DO 300 L = 1,I-1 + W(J,L) = W(J,L) + WS(N3+J-1)*WS(L) + 300 CONTINUE +C + DO 310 L = I,J + W(J,L) = W(J,L) + WS(J)*WS(N3+L-1)+WS(L)*WS(N3+J-1) + 310 CONTINUE + 320 CONTINUE + ENDIF + 330 CONTINUE +C +C Copy lower triangle to upper triangle to symmetrize the +C covariance matrix. +C + DO 340 I = 1,N + CALL DCOPY (I, W(I,1), MDW, W(1,I), 1) + 340 CONTINUE + ENDIF +C +C Repermute rows and columns. +C + DO 350 I = MINMAN,1,-1 + K = IP(I) + IF (I.NE.K) THEN + CALL DSWAP (1, W(I,I), 1, W(K,K), 1) + CALL DSWAP (I-1, W(1,I), 1, W(1,K), 1) + CALL DSWAP (K-I-1, W(I,I+1), MDW, W(I+1,K), 1) + CALL DSWAP (N-K, W(I, K+1), MDW, W(K, K+1), MDW) + ENDIF + 350 CONTINUE +C +C Put in normalized residual sum of squares scale factor +C and symmetrize the resulting covariance matrix. +C + DO 360 J = 1,N + CALL DSCAL (J, FAC, W(1,J), 1) + CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) + 360 CONTINUE +C + 370 IP(1) = KRANK + IP(2) = N + MAX(M,N) + (MG+2)*(N+7) + RETURN + END +*DECK D1MACH + DOUBLE PRECISION FUNCTION D1MACH (I) +C***BEGIN PROLOGUE D1MACH +C***PURPOSE Return floating point machine dependent constants. +C***LIBRARY SLATEC +C***CATEGORY R1 +C***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) +C***KEYWORDS MACHINE CONSTANTS +C***AUTHOR Fox, P. A., (Bell Labs) +C Hall, A. D., (Bell Labs) +C Schryer, N. L., (Bell Labs) +C***DESCRIPTION +C +C D1MACH can be used to obtain machine-dependent parameters for the +C local machine environment. It is a function subprogram with one +C (input) argument, and can be referenced as follows: +C +C D = D1MACH(I) +C +C where I=1,...,5. The (output) value of D above is determined by +C the (input) value of I. The results for various values of I are +C discussed below. +C +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 Assume double precision numbers are represented in the T-digit, +C base-B form +C +C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and +C EMIN .LE. E .LE. EMAX. +C +C The values of B, T, EMIN and EMAX are provided in I1MACH as +C follows: +C I1MACH(10) = B, the base. +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 +C To alter this function for a particular environment, the desired +C set of DATA statements should be activated by removing the C from +C column 1. Also, the values of D1MACH(1) - D1MACH(4) should be +C checked for consistency with the local operating system. +C +C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +C a portable library, ACM Transactions on Mathematical +C Software 4, 2 (June 1978), pp. 177-188. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 890213 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900618 Added DEC RISC constants. (WRB) +C 900723 Added IBM RS 6000 constants. (WRB) +C 900911 Added SUN 386i constants. (WRB) +C 910710 Added HP 730 constants. (SMR) +C 911114 Added Convex IEEE constants. (WRB) +C 920121 Added SUN -r8 compiler option constants. (WRB) +C 920229 Added Touchstone Delta i860 constants. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 920625 Added CONVEX -p8 and -pd8 compiler option constants. +C (BKS, WRB) +C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) +C 010817 Elevated IEEE to highest importance; see next set of +C comments below. (DWL) +C***END PROLOGUE D1MACH +C + + INTEGER SMALL(4) + INTEGER LARGE(4) + INTEGER RIGHT(4) + INTEGER DIVER(4) + INTEGER LOG10(4) +C +C Initial data here correspond to the IEEE standard. The values for +C DMACH(1), DMACH(3) and DMACH(4) are slight upper bounds. The value +C for DMACH(2) is a slight lower bound. The value for DMACH(5) is +C a 20-digit approximation. If one of the sets of initial data below +C is preferred, do the necessary commenting and uncommenting. (DWL) + DOUBLE PRECISION DMACH(5) + DATA DMACH / 2.23D-308, 1.79D+308, 1.111D-16, 2.222D-16, + 1 0.30102999566398119521D0 / + SAVE DMACH +C + 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 AMIGA +C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE APOLLO +C +C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / +C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / +C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / +C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM +C +C DATA SMALL(1) / ZC00800000 / +C DATA SMALL(2) / Z000000000 / +C DATA LARGE(1) / ZDFFFFFFFF / +C DATA LARGE(2) / ZFFFFFFFFF / +C DATA RIGHT(1) / ZCC5800000 / +C DATA RIGHT(2) / Z000000000 / +C DATA DIVER(1) / ZCC6800000 / +C DATA DIVER(2) / Z000000000 / +C DATA LOG10(1) / ZD00E730E7 / +C DATA LOG10(2) / ZC77800DC0 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O0000000000000000 / +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O0007777777777777 / +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O7770000000000000 / +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O7777777777777777 / +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 / +C +C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE +C +C DATA SMALL(1) / Z"3001800000000000" / +C DATA SMALL(2) / Z"3001000000000000" / +C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / +C DATA LARGE(2) / Z"4FFE000000000000" / +C DATA RIGHT(1) / Z"3FD2800000000000" / +C DATA RIGHT(2) / Z"3FD2000000000000" / +C DATA DIVER(1) / Z"3FD3800000000000" / +C DATA DIVER(2) / Z"3FD3000000000000" / +C DATA LOG10(1) / Z"3FFF9A209A84FBCF" / +C DATA LOG10(2) / Z"3FFFF7988F8959AC" / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES +C +C DATA SMALL(1) / 00564000000000000000B / +C DATA SMALL(2) / 00000000000000000000B / +C DATA LARGE(1) / 37757777777777777777B / +C DATA LARGE(2) / 37157777777777777777B / +C DATA RIGHT(1) / 15624000000000000000B / +C DATA RIGHT(2) / 00000000000000000000B / +C DATA DIVER(1) / 15634000000000000000B / +C DATA DIVER(2) / 00000000000000000000B / +C DATA LOG10(1) / 17164642023241175717B / +C DATA LOG10(2) / 16367571421742254654B / +C +C MACHINE CONSTANTS FOR THE CELERITY C1260 +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fn OR -pd8 COMPILER OPTION +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CC0000000000000' / +C DATA DMACH(4) / Z'3CD0000000000000' / +C DATA DMACH(5) / Z'3FF34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fi COMPILER OPTION +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -p8 COMPILER OPTION +C +C DATA DMACH(1) / Z'00010000000000000000000000000000' / +C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3F900000000000000000000000000000' / +C DATA DMACH(4) / Z'3F910000000000000000000000000000' / +C DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / +C +C MACHINE CONSTANTS FOR THE CRAY +C +C DATA SMALL(1) / 201354000000000000000B / +C DATA SMALL(2) / 000000000000000000000B / +C DATA LARGE(1) / 577767777777777777777B / +C DATA LARGE(2) / 000007777777777777774B / +C DATA RIGHT(1) / 376434000000000000000B / +C DATA RIGHT(2) / 000000000000000000000B / +C DATA DIVER(1) / 376444000000000000000B / +C DATA DIVER(2) / 000000000000000000000B / +C DATA LOG10(1) / 377774642023241175717B / +C DATA LOG10(2) / 000007571421742254654B / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - +C STATIC DMACH(5) +C +C DATA SMALL / 20K, 3*0 / +C DATA LARGE / 77777K, 3*177777K / +C DATA RIGHT / 31420K, 3*0 / +C DATA DIVER / 32020K, 3*0 / +C DATA LOG10 / 40423K, 42023K, 50237K, 74776K / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING G_FLOAT +C +C DATA DMACH(1) / '0000000000000010'X / +C DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / +C DATA DMACH(3) / '0000000000003CC0'X / +C DATA DMACH(4) / '0000000000003CD0'X / +C DATA DMACH(5) / '79FF509F44133FF3'X / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING IEEE_FORMAT +C +C DATA DMACH(1) / '0010000000000000'X / +C DATA DMACH(2) / '7FEFFFFFFFFFFFFF'X / +C DATA DMACH(3) / '3CA0000000000000'X / +C DATA DMACH(4) / '3CB0000000000000'X / +C DATA DMACH(5) / '3FD34413509F79FF'X / +C +C MACHINE CONSTANTS FOR THE DEC RISC +C +C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ +C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ +C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ +C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ +C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING D_FLOATING +C (EXPRESSED IN INTEGER AND HEXADECIMAL) +C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS +C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS +C +C DATA SMALL(1), SMALL(2) / 128, 0 / +C DATA LARGE(1), LARGE(2) / -32769, -1 / +C DATA RIGHT(1), RIGHT(2) / 9344, 0 / +C DATA DIVER(1), DIVER(2) / 9472, 0 / +C DATA LOG10(1), LOG10(2) / 546979738, -805796613 / +C +C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / +C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING G_FLOATING +C (EXPRESSED IN INTEGER AND HEXADECIMAL) +C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS +C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS +C +C DATA SMALL(1), SMALL(2) / 16, 0 / +C DATA LARGE(1), LARGE(2) / -32769, -1 / +C DATA RIGHT(1), RIGHT(2) / 15552, 0 / +C DATA DIVER(1), DIVER(2) / 15568, 0 / +C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / +C +C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / +C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / +C +C MACHINE CONSTANTS FOR THE ELXSI 6400 +C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) +C +C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / +C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / +C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / +C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / +C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / +C +C MACHINE CONSTANTS FOR THE HARRIS 220 +C +C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / +C DATA LARGE(1), LARGE(2) / '37777777, '37777577 / +C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / +C DATA DIVER(1), DIVER(2) / '20000000, '00000334 / +C DATA LOG10(1), LOG10(2) / '23210115, '10237777 / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES +C +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 / +C +C MACHINE CONSTANTS FOR THE HP 730 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / +C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / +C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / +C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / +C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA SMALL(1), SMALL(2) / 40000B, 0 / +C DATA SMALL(3), SMALL(4) / 0, 1 / +C DATA LARGE(1), LARGE(2) / 77777B, 177777B / +C DATA LARGE(3), LARGE(4) / 177777B, 177776B / +C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / +C DATA RIGHT(3), RIGHT(4) / 0, 225B / +C DATA DIVER(1), DIVER(2) / 40000B, 0 / +C DATA DIVER(3), DIVER(4) / 0, 227B / +C DATA LOG10(1), LOG10(2) / 46420B, 46502B / +C DATA LOG10(3), LOG10(4) / 76747B, 176377B / +C +C MACHINE CONSTANTS FOR THE HP 9000 +C +C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / +C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / +C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / +C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / +C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND +C THE PERKIN ELMER (INTERDATA) 7/32. +C +C DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / +C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / +C +C MACHINE CONSTANTS FOR THE IBM PC +C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION +C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. +C +C DATA SMALL(1) / 2.23D-308 / +C DATA LARGE(1) / 1.79D+308 / +C DATA RIGHT(1) / 1.11D-16 / +C DATA DIVER(1) / 2.22D-16 / +C DATA LOG10(1) / 0.301029995663981195D0 / +C +C MACHINE CONSTANTS FOR THE IBM RS 6000 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE INTEL i860 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) +C +C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / +C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / +C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / +C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / +C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) +C +C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / +C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / +C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / +C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / +C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +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 / +C +C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / +C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / +C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / +C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / +C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA SMALL(1), SMALL(2) / 128, 0 / +C DATA SMALL(3), SMALL(4) / 0, 0 / +C DATA LARGE(1), LARGE(2) / 32767, -1 / +C DATA LARGE(3), LARGE(4) / -1, -1 / +C DATA RIGHT(1), RIGHT(2) / 9344, 0 / +C DATA RIGHT(3), RIGHT(4) / 0, 0 / +C DATA DIVER(1), DIVER(2) / 9472, 0 / +C DATA DIVER(3), DIVER(4) / 0, 0 / +C DATA LOG10(1), LOG10(2) / 16282, 8346 / +C DATA LOG10(3), LOG10(4) / -31493, -12296 / +C +C DATA SMALL(1), SMALL(2) / O000200, O000000 / +C DATA SMALL(3), SMALL(4) / O000000, O000000 / +C DATA LARGE(1), LARGE(2) / O077777, O177777 / +C DATA LARGE(3), LARGE(4) / O177777, O177777 / +C DATA RIGHT(1), RIGHT(2) / O022200, O000000 / +C DATA RIGHT(3), RIGHT(4) / O000000, O000000 / +C DATA DIVER(1), DIVER(2) / O022400, O000000 / +C DATA DIVER(3), DIVER(4) / O000000, O000000 / +C DATA LOG10(1), LOG10(2) / O037632, O020232 / +C DATA LOG10(3), LOG10(4) / O102373, O147770 / +C +C MACHINE CONSTANTS FOR THE SILICON GRAPHICS +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE SUN +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE SUN +C USING THE -r8 COMPILER OPTION +C +C DATA DMACH(1) / Z'00010000000000000000000000000000' / +C DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / +C DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / +C DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / +C +C MACHINE CONSTANTS FOR THE SUN 386i +C +C DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / +C DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / +C DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' +C DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER +C +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 / +C +C***FIRST EXECUTABLE STATEMENT D1MACH +C IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'D1MACH', +C + 'I OUT OF BOUNDS', 1, 2) +C + D1MACH = DMACH(I) + RETURN +C + END +*DECK I1MACH + INTEGER FUNCTION I1MACH (I) +C***BEGIN PROLOGUE I1MACH +C***PURPOSE Return integer machine dependent constants. +C***LIBRARY SLATEC +C***CATEGORY R1 +C***TYPE INTEGER (I1MACH-I) +C***KEYWORDS MACHINE CONSTANTS +C***AUTHOR Fox, P. A., (Bell Labs) +C Hall, A. D., (Bell Labs) +C Schryer, N. L., (Bell Labs) +C***DESCRIPTION +C +C I1MACH can be used to obtain machine-dependent parameters for the +C local machine environment. It is a function subprogram with one +C (input) argument and can be referenced as follows: +C +C K = I1MACH(I) +C +C where I=1,...,16. The (output) value of K above is determined by +C the (input) value of I. The results for various values of I are +C discussed below. +C +C I/O unit numbers: +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 +C Words: +C I1MACH( 5) = the number of bits per integer storage unit. +C I1MACH( 6) = the number of characters per integer storage unit. +C +C Integers: +C assume integers are represented in the S-digit, base-A form +C +C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) +C +C where 0 .LE. X(I) .LT. A for I=0,...,S-1. +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 +C Floating-Point Numbers: +C Assume floating-point numbers are represented in the T-digit, +C base-B form +C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C where 0 .LE. X(I) .LT. B for I=1,...,T, +C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. +C I1MACH(10) = B, the base. +C +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 +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 +C To alter this function for a particular environment, the desired +C set of DATA statements should be activated by removing the C from +C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be +C checked for consistency with the local operating system. +C +C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +C a portable library, ACM Transactions on Mathematical +C Software 4, 2 (June 1978), pp. 177-188. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 891012 Added VAX G-floating constants. (WRB) +C 891012 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900618 Added DEC RISC constants. (WRB) +C 900723 Added IBM RS 6000 constants. (WRB) +C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. +C (RWC) +C 910710 Added HP 730 constants. (SMR) +C 911114 Added Convex IEEE constants. (WRB) +C 920121 Added SUN -r8 compiler option constants. (WRB) +C 920229 Added Touchstone Delta i860 constants. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 920625 Added Convex -p8 and -pd8 compiler option constants. +C (BKS, WRB) +C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) +C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler +C options. (DWL, RWC and WRB). +C 010817 Elevated IEEE to highest importance; see next set of +C comments below. (DWL) +C***END PROLOGUE I1MACH +C +C Initial data here correspond to the IEEE standard. If one of the +C sets of initial data below is preferred, do the necessary commenting +C and uncommenting. (DWL) + INTEGER IMACH(16),OUTPUT + DATA IMACH( 1) / 5 / + DATA IMACH( 2) / 6 / + DATA IMACH( 3) / 6 / + DATA IMACH( 4) / 6 / + DATA IMACH( 5) / 32 / + DATA IMACH( 6) / 4 / + DATA IMACH( 7) / 2 / + DATA IMACH( 8) / 31 / + DATA IMACH( 9) / 2147483647 / + DATA IMACH(10) / 2 / + DATA IMACH(11) / 24 / + DATA IMACH(12) / -126 / + DATA IMACH(13) / 127 / + DATA IMACH(14) / 53 / + DATA IMACH(15) / -1022 / + DATA IMACH(16) / 1023 / + SAVE IMACH + EQUIVALENCE (IMACH(4),OUTPUT) +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT COMPILER +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE APOLLO +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 129 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1025 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM +C +C DATA IMACH( 1) / 7 / +C DATA IMACH( 2) / 2 / +C DATA IMACH( 3) / 2 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 33 / +C DATA IMACH( 9) / Z1FFFFFFFF / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -256 / +C DATA IMACH(13) / 255 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) / -256 / +C DATA IMACH(16) / 255 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM +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) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -50 / +C DATA IMACH(16) / 76 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS +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) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -32754 / +C DATA IMACH(16) / 32780 / +C +C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE +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) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -4095 / +C DATA IMACH(13) / 4094 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -4095 / +C DATA IMACH(16) / 4094 / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6LOUTPUT/ +C DATA IMACH( 5) / 60 / +C DATA IMACH( 6) / 10 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 48 / +C DATA IMACH( 9) / 00007777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -929 / +C DATA IMACH(13) / 1070 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -929 / +C DATA IMACH(16) / 1069 / +C +C MACHINE CONSTANTS FOR THE CELERITY C1260 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 0 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / Z'7FFFFFFF' / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fn COMPILER OPTION +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) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fi COMPILER OPTION +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -p8 COMPILER OPTION +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) / 64 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1023 / +C DATA IMACH(13) / 1023 / +C DATA IMACH(14) / 113 / +C DATA IMACH(15) / -16383 / +C DATA IMACH(16) / 16383 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -pd8 COMPILER OPTION +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) / 64 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1023 / +C DATA IMACH(13) / 1023 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CRAY +C USING THE 46 BIT INTEGER COMPILER OPTION +C +C DATA IMACH( 1) / 100 / +C DATA IMACH( 2) / 101 / +C DATA IMACH( 3) / 102 / +C DATA IMACH( 4) / 101 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 46 / +C DATA IMACH( 9) / 1777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -8189 / +C DATA IMACH(13) / 8190 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -8099 / +C DATA IMACH(16) / 8190 / +C +C MACHINE CONSTANTS FOR THE CRAY +C USING THE 64 BIT INTEGER COMPILER OPTION +C +C DATA IMACH( 1) / 100 / +C DATA IMACH( 2) / 101 / +C DATA IMACH( 3) / 102 / +C DATA IMACH( 4) / 101 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 777777777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -8189 / +C DATA IMACH(13) / 8190 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -8099 / +C DATA IMACH(16) / 8190 / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C +C DATA IMACH( 1) / 11 / +C DATA IMACH( 2) / 12 / +C DATA IMACH( 3) / 8 / +C DATA IMACH( 4) / 10 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING G_FLOAT +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING IEEE_FLOAT +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE DEC RISC +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING D_FLOATING +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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 / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING G_FLOATING +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE ELXSI 6400 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 32 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE HARRIS 220 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / 3 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 23 / +C DATA IMACH( 9) / 8388607 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 38 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 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) / 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) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 63 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 730 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 4 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 39 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 4 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 55 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 9000 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 7 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 32 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1015 / +C DATA IMACH(16) / 1017 / +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND +C THE PERKIN ELMER (INTERDATA) 7/32. +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) / Z7FFFFFFF / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 / +C +C MACHINE CONSTANTS FOR THE IBM PC +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 0 / +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) / -125 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE IBM RS 6000 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 0 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE INTEL i860 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 54 / +C DATA IMACH(15) / -101 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 62 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 16-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +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 / +C +C MACHINE CONSTANTS FOR THE SILICON GRAPHICS +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE SUN +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE SUN +C USING THE -r8 COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / 53 / +C DATA IMACH(12) / -1021 / +C DATA IMACH(13) / 1024 / +C DATA IMACH(14) / 113 / +C DATA IMACH(15) / -16381 / +C DATA IMACH(16) / 16384 / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 1 / +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) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) / -1024 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR +C +C DATA IMACH( 1) / 1 / +C DATA IMACH( 2) / 1 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +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 / +C +C***FIRST EXECUTABLE STATEMENT I1MACH + IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 +C + I1MACH = IMACH(I) + RETURN +C + 10 CONTINUE + WRITE (UNIT = OUTPUT, FMT = 9000) + 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') +C +C CALL FDUMP +C + STOP + END +*DECK DH12 + SUBROUTINE DH12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV, + + NCV) +C***BEGIN PROLOGUE DH12 +C***SUBSIDIARY +C***PURPOSE Subsidiary to DHFTI, DLSEI and DWNNLS +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (H12-S, DH12-D) +C***AUTHOR (UNKNOWN) +C***DESCRIPTION +C +C *** DOUBLE PRECISION VERSION OF H12 ****** +C +C C.L.Lawson and R.J.Hanson, Jet Propulsion Laboratory, 1973 Jun 12 +C to appear in 'Solving Least Squares Problems', Prentice-Hall, 1974 +C +C Construction and/or application of a single +C Householder transformation.. Q = I + U*(U**T)/B +C +C MODE = 1 or 2 to select algorithm H1 or H2 . +C LPIVOT is the index of the pivot element. +C L1,M If L1 .LE. M the transformation will be constructed to +C zero elements indexed from L1 through M. If L1 GT. M +C THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. +C U(),IUE,UP On entry to H1 U() contains the pivot vector. +C IUE is the storage increment between elements. +C On exit from H1 U() and UP +C contain quantities defining the vector U of the +C Householder transformation. On entry to H2 U() +C and UP should contain quantities previously computed +C by H1. These will not be modified by H2. +C C() On entry to H1 or H2 C() contains a matrix which will be +C regarded as a set of vectors to which the Householder +C transformation is to be applied. On exit C() contains the +C set of transformed vectors. +C ICE Storage increment between elements of vectors in C(). +C ICV Storage increment between vectors in C(). +C NCV Number of vectors in C() to be transformed. If NCV .LE. 0 +C no operations will be done on C(). +C +C***SEE ALSO DHFTI, DLSEI, DWNNLS +C***ROUTINES CALLED DAXPY, DDOT, DSWAP +C***REVISION HISTORY (YYMMDD) +C 790101 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900911 Added DDOT to DOUBLE PRECISION statement. (WRB) +C***END PROLOGUE DH12 + + INTEGER I, I2, I3, I4, ICE, ICV, INCR, IUE, J, KL1, KL2, KLP, + * L1, L1M1, LPIVOT, M, MML1P2, MODE, NCV + DOUBLE PRECISION B, C, CL, CLINV, ONE, UL1M1, SM, U, UP, DDOT + DIMENSION U(IUE,*), C(*) +C BEGIN BLOCK PERMITTING ...EXITS TO 140 +C***FIRST EXECUTABLE STATEMENT DH12 + ONE = 1.0D0 +C +C ...EXIT + IF (0 .GE. LPIVOT .OR. LPIVOT .GE. L1 .OR. L1 .GT. M) GO TO 140 + CL = ABS(U(1,LPIVOT)) + IF (MODE .EQ. 2) GO TO 40 +C ****** CONSTRUCT THE TRANSFORMATION. ****** + DO 10 J = L1, M + CL = MAX(ABS(U(1,J)),CL) + 10 CONTINUE + IF (CL .GT. 0.0D0) GO TO 20 +C .........EXIT + GO TO 140 + 20 CONTINUE + CLINV = ONE/CL + SM = (U(1,LPIVOT)*CLINV)**2 + DO 30 J = L1, M + SM = SM + (U(1,J)*CLINV)**2 + 30 CONTINUE + CL = CL*SQRT(SM) + IF (U(1,LPIVOT) .GT. 0.0D0) CL = -CL + UP = U(1,LPIVOT) - CL + U(1,LPIVOT) = CL + GO TO 50 + 40 CONTINUE +C ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** +C + IF (CL .GT. 0.0D0) GO TO 50 +C ......EXIT + GO TO 140 + 50 CONTINUE +C ...EXIT + IF (NCV .LE. 0) GO TO 140 + B = UP*U(1,LPIVOT) +C B MUST BE NONPOSITIVE HERE. IF B = 0., RETURN. +C + IF (B .LT. 0.0D0) GO TO 60 +C ......EXIT + GO TO 140 + 60 CONTINUE + B = ONE/B + MML1P2 = M - L1 + 2 + IF (MML1P2 .LE. 20) GO TO 80 + L1M1 = L1 - 1 + KL1 = 1 + (L1M1 - 1)*ICE + KL2 = KL1 + KLP = 1 + (LPIVOT - 1)*ICE + UL1M1 = U(1,L1M1) + U(1,L1M1) = UP + IF (LPIVOT .NE. L1M1) CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) + DO 70 J = 1, NCV + SM = DDOT(MML1P2,U(1,L1M1),IUE,C(KL1),ICE) + SM = SM*B + CALL DAXPY(MML1P2,SM,U(1,L1M1),IUE,C(KL1),ICE) + KL1 = KL1 + ICV + 70 CONTINUE + U(1,L1M1) = UL1M1 +C ......EXIT + IF (LPIVOT .EQ. L1M1) GO TO 140 + KL1 = KL2 + CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) + GO TO 130 + 80 CONTINUE + I2 = 1 - ICV + ICE*(LPIVOT - 1) + INCR = ICE*(L1 - LPIVOT) + DO 120 J = 1, NCV + I2 = I2 + ICV + I3 = I2 + INCR + I4 = I3 + SM = C(I2)*UP + DO 90 I = L1, M + SM = SM + C(I3)*U(1,I) + I3 = I3 + ICE + 90 CONTINUE + IF (SM .EQ. 0.0D0) GO TO 110 + SM = SM*B + C(I2) = C(I2) + SM*UP + DO 100 I = L1, M + C(I4) = C(I4) + SM*U(1,I) + I4 = I4 + ICE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + RETURN + END +*DECK DHFTI + SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, + + G, IP) +C***BEGIN PROLOGUE DHFTI +C***PURPOSE Solve a least squares problem for banded matrices using +C sequential accumulation of rows of the data matrix. +C Exactly one right-hand side vector is permitted. +C***LIBRARY SLATEC +C***CATEGORY D9 +C***TYPE DOUBLE PRECISION (HFTI-S, DHFTI-D) +C***KEYWORDS CURVE FITTING, LEAST SQUARES +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C***DESCRIPTION +C +C DIMENSION A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N) +C +C This subroutine solves a linear least squares problem or a set of +C linear least squares problems having the same matrix but different +C right-side vectors. The problem data consists of an M by N matrix +C A, an M by NB matrix B, and an absolute tolerance parameter TAU +C whose usage is described below. The NB column vectors of B +C represent right-side vectors for NB distinct linear least squares +C problems. +C +C This set of problems can also be written as the matrix least +C squares problem +C +C AX = B, +C +C where X is the N by NB solution matrix. +C +C Note that if B is the M by M identity matrix, then X will be the +C pseudo-inverse of A. +C +C This subroutine first transforms the augmented matrix (A B) to a +C matrix (R C) using premultiplying Householder transformations with +C column interchanges. All subdiagonal elements in the matrix R are +C zero and its diagonal elements satisfy +C +C ABS(R(I,I)).GE.ABS(R(I+1,I+1)), +C +C I = 1,...,L-1, where +C +C L = MIN(M,N). +C +C The subroutine will compute an integer, KRANK, equal to the number +C of diagonal terms of R that exceed TAU in magnitude. Then a +C solution of minimum Euclidean length is computed using the first +C KRANK rows of (R C). +C +C To be specific we suggest that the user consider an easily +C computable matrix norm, such as, the maximum of all column sums of +C magnitudes. +C +C Now if the relative uncertainty of B is EPS, (norm of uncertainty/ +C norm of B), it is suggested that TAU be set approximately equal to +C EPS*(norm of A). +C +C The user must dimension all arrays appearing in the call list.. +C A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N). This +C permits the solution of a range of problems in the same array +C space. +C +C The entire set of parameters for DHFTI are +C +C INPUT.. All TYPE REAL variables are DOUBLE PRECISION +C +C A(*,*),MDA,M,N The array A(*,*) initially contains the M by N +C matrix A of the least squares problem AX = B. +C The first dimensioning parameter of the array +C A(*,*) is MDA, which must satisfy MDA.GE.M +C Either M.GE.N or M.LT.N is permitted. There +C is no restriction on the rank of A. The +C condition MDA.LT.M is considered an error. +C +C B(*),MDB,NB If NB = 0 the subroutine will perform the +C orthogonal decomposition but will make no +C references to the array B(*). If NB.GT.0 +C the array B(*) must initially contain the M by +C NB matrix B of the least squares problem AX = +C B. If NB.GE.2 the array B(*) must be doubly +C subscripted with first dimensioning parameter +C MDB.GE.MAX(M,N). If NB = 1 the array B(*) may +C be either doubly or singly subscripted. In +C the latter case the value of MDB is arbitrary +C but it should be set to some valid integer +C value such as MDB = M. +C +C The condition of NB.GT.1.AND.MDB.LT. MAX(M,N) +C is considered an error. +C +C TAU Absolute tolerance parameter provided by user +C for pseudorank determination. +C +C H(*),G(*),IP(*) Arrays of working space used by DHFTI. +C +C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION +C +C A(*,*) The contents of the array A(*,*) will be +C modified by the subroutine. These contents +C are not generally required by the user. +C +C B(*) On return the array B(*) will contain the N by +C NB solution matrix X. +C +C KRANK Set by the subroutine to indicate the +C pseudorank of A. +C +C RNORM(*) On return, RNORM(J) will contain the Euclidean +C norm of the residual vector for the problem +C defined by the J-th column vector of the array +C B(*,*) for J = 1,...,NB. +C +C H(*),G(*) On return these arrays respectively contain +C elements of the pre- and post-multiplying +C Householder transformations used to compute +C the minimum Euclidean length solution. +C +C IP(*) Array in which the subroutine records indices +C describing the permutation of column vectors. +C The contents of arrays H(*),G(*) and IP(*) +C are not generally required by the user. +C +C***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares +C Problems, Prentice-Hall, Inc., 1974, Chapter 14. +C***ROUTINES CALLED D1MACH, DH12, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790101 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 891006 Cosmetic changes to prologue. (WRB) +C 891006 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 901005 Replace usage of DDIFF with usage of D1MACH. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DHFTI + + INTEGER I, II, IOPT, IP(*), IP1, J, JB, JJ, K, KP1, KRANK, L, + * LDIAG, LMAX, M, MDA, MDB, N, NB, NERR + DOUBLE PRECISION A, B, D1MACH, DZERO, FACTOR, + * G, H, HMAX, RELEPS, RNORM, SM, SM1, SZERO, TAU, TMP + DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*) + SAVE RELEPS + DATA RELEPS /0.D0/ +C BEGIN BLOCK PERMITTING ...EXITS TO 360 +C***FIRST EXECUTABLE STATEMENT DHFTI + IF (RELEPS.EQ.0.D0) RELEPS = D1MACH(4) + SZERO = 0.0D0 + DZERO = 0.0D0 + FACTOR = 0.001D0 +C + K = 0 + LDIAG = MIN(M,N) + IF (LDIAG .LE. 0) GO TO 350 +C BEGIN BLOCK PERMITTING ...EXITS TO 130 +C BEGIN BLOCK PERMITTING ...EXITS TO 120 + IF (MDA .GE. M) GO TO 10 + NERR = 1 + IOPT = 2 +C CALL XERMSG ('SLATEC', 'DHFTI', +C + 'MDA.LT.M, PROBABLE ERROR.', +C + NERR, IOPT) +C ...............EXIT + GO TO 360 + 10 CONTINUE +C + IF (NB .LE. 1 .OR. MAX(M,N) .LE. MDB) GO TO 20 + NERR = 2 + IOPT = 2 +C CALL XERMSG ('SLATEC', 'DHFTI', +C + 'MDB.LT.MAX(M,N).AND.NB.GT.1. PROBABLE ERROR.', +C + NERR, IOPT) +C ...............EXIT + GO TO 360 + 20 CONTINUE +C + DO 100 J = 1, LDIAG +C BEGIN BLOCK PERMITTING ...EXITS TO 70 + IF (J .EQ. 1) GO TO 40 +C +C UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX +C .. + LMAX = J + DO 30 L = J, N + H(L) = H(L) - A(J-1,L)**2 + IF (H(L) .GT. H(LMAX)) LMAX = L + 30 CONTINUE +C ......EXIT + IF (FACTOR*H(LMAX) .GT. HMAX*RELEPS) GO TO 70 + 40 CONTINUE +C +C COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX +C .. + LMAX = J + DO 60 L = J, N + H(L) = 0.0D0 + DO 50 I = J, M + H(L) = H(L) + A(I,L)**2 + 50 CONTINUE + IF (H(L) .GT. H(LMAX)) LMAX = L + 60 CONTINUE + HMAX = H(LMAX) + 70 CONTINUE +C .. +C LMAX HAS BEEN DETERMINED +C +C DO COLUMN INTERCHANGES IF NEEDED. +C .. + IP(J) = LMAX + IF (IP(J) .EQ. J) GO TO 90 + DO 80 I = 1, M + TMP = A(I,J) + A(I,J) = A(I,LMAX) + A(I,LMAX) = TMP + 80 CONTINUE + H(LMAX) = H(J) + 90 CONTINUE +C +C COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A +C AND B. +C .. + CALL DH12(1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA, + * N-J) + CALL DH12(2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB) + 100 CONTINUE +C +C DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, +C TAU. +C .. + DO 110 J = 1, LDIAG +C ......EXIT + IF (ABS(A(J,J)) .LE. TAU) GO TO 120 + 110 CONTINUE + K = LDIAG +C ......EXIT + GO TO 130 + 120 CONTINUE + K = J - 1 + 130 CONTINUE + KP1 = K + 1 +C +C COMPUTE THE NORMS OF THE RESIDUAL VECTORS. +C + IF (NB .LT. 1) GO TO 170 + DO 160 JB = 1, NB + TMP = SZERO + IF (M .LT. KP1) GO TO 150 + DO 140 I = KP1, M + TMP = TMP + B(I,JB)**2 + 140 CONTINUE + 150 CONTINUE + RNORM(JB) = SQRT(TMP) + 160 CONTINUE + 170 CONTINUE +C SPECIAL FOR PSEUDORANK = 0 + IF (K .GT. 0) GO TO 210 + IF (NB .LT. 1) GO TO 200 + DO 190 JB = 1, NB + DO 180 I = 1, N + B(I,JB) = SZERO + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + GO TO 340 + 210 CONTINUE +C +C IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER +C DECOMPOSITION OF FIRST K ROWS. +C .. + IF (K .EQ. N) GO TO 230 + DO 220 II = 1, K + I = KP1 - II + CALL DH12(1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1) + 220 CONTINUE + 230 CONTINUE +C +C + IF (NB .LT. 1) GO TO 330 + DO 320 JB = 1, NB +C +C SOLVE THE K BY K TRIANGULAR SYSTEM. +C .. + DO 260 L = 1, K + SM = DZERO + I = KP1 - L + IP1 = I + 1 + IF (K .LT. IP1) GO TO 250 + DO 240 J = IP1, K + SM = SM + A(I,J)*B(J,JB) + 240 CONTINUE + 250 CONTINUE + SM1 = SM + B(I,JB) = (B(I,JB) - SM1)/A(I,I) + 260 CONTINUE +C +C COMPLETE COMPUTATION OF SOLUTION VECTOR. +C .. + IF (K .EQ. N) GO TO 290 + DO 270 J = KP1, N + B(J,JB) = SZERO + 270 CONTINUE + DO 280 I = 1, K + CALL DH12(2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1, + * MDB,1) + 280 CONTINUE + 290 CONTINUE +C +C RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE +C COLUMN INTERCHANGES. +C .. + DO 310 JJ = 1, LDIAG + J = LDIAG + 1 - JJ + IF (IP(J) .EQ. J) GO TO 300 + L = IP(J) + TMP = B(L,JB) + B(L,JB) = B(J,JB) + B(J,JB) = TMP + 300 CONTINUE + 310 CONTINUE + 320 CONTINUE + 330 CONTINUE + 340 CONTINUE + 350 CONTINUE +C .. +C THE SOLUTION VECTORS, X, ARE NOW +C IN THE FIRST N ROWS OF THE ARRAY B(,). +C + KRANK = K + 360 CONTINUE + RETURN + END +*DECK DLPDP + SUBROUTINE DLPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, + + IS) +C***BEGIN PROLOGUE DLPDP +C***SUBSIDIARY +C***PURPOSE Subsidiary to DLSEI +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (LPDP-S, DLPDP-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C **** Double Precision version of LPDP **** +C DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1), +C where N=N1+N2. This is a slight overestimate for WS(*). +C +C Determine an N1-vector W, and +C an N2-vector Z +C which minimizes the Euclidean length of W +C subject to G*W+H*Z .GE. Y. +C This is the least projected distance problem, LPDP. +C The matrices G and H are of respective +C dimensions M by N1 and M by N2. +C +C Called by subprogram DLSI( ). +C +C The matrix +C (G H Y) +C +C occupies rows 1,...,M and cols 1,...,N1+N2+1 of A(*,*). +C +C The solution (W) is returned in X(*). +C (Z) +C +C The value of MODE indicates the status of +C the computation after returning to the user. +C +C MODE=1 The solution was successfully obtained. +C +C MODE=2 The inequalities are inconsistent. +C +C***SEE ALSO DLSEI +C***ROUTINES CALLED DCOPY, DDOT, DNRM2, DSCAL, DWNNLS +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910408 Updated the AUTHOR section. (WRB) +C***END PROLOGUE DLPDP + +C + INTEGER I, IS(*), IW, IX, J, L, M, MDA, MODE, MODEW, N, N1, N2, + * NP1 + DOUBLE PRECISION A(MDA,*), DDOT, DNRM2, FAC, ONE, + * PRGOPT(*), RNORM, SC, WNORM, WS(*), X(*), YNORM, ZERO + SAVE ZERO, ONE, FAC + DATA ZERO,ONE /0.0D0,1.0D0/, FAC /0.1D0/ +C***FIRST EXECUTABLE STATEMENT DLPDP + N = N1 + N2 + MODE = 1 + IF (M .GT. 0) GO TO 20 + IF (N .LE. 0) GO TO 10 + X(1) = ZERO + CALL DCOPY(N,X,0,X,1) + 10 CONTINUE + WNORM = ZERO + GO TO 200 + 20 CONTINUE +C BEGIN BLOCK PERMITTING ...EXITS TO 190 + NP1 = N + 1 +C +C SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE. + DO 40 I = 1, M + SC = DNRM2(N,A(I,1),MDA) + IF (SC .EQ. ZERO) GO TO 30 + SC = ONE/SC + CALL DSCAL(NP1,SC,A(I,1),MDA) + 30 CONTINUE + 40 CONTINUE +C +C SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO). + YNORM = DNRM2(M,A(1,NP1),1) + IF (YNORM .EQ. ZERO) GO TO 50 + SC = ONE/YNORM + CALL DSCAL(M,SC,A(1,NP1),1) + 50 CONTINUE +C +C SCALE COLS OF MATRIX H. + J = N1 + 1 + 60 IF (J .GT. N) GO TO 70 + SC = DNRM2(M,A(1,J),1) + IF (SC .NE. ZERO) SC = ONE/SC + CALL DSCAL(M,SC,A(1,J),1) + X(J) = SC + J = J + 1 + GO TO 60 + 70 CONTINUE + IF (N1 .LE. 0) GO TO 130 +C +C COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*). + IW = 0 + DO 80 I = 1, M +C +C MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY. + CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) + IW = IW + N2 +C +C MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY. + CALL DCOPY(N1,A(I,1),MDA,WS(IW+1),1) + IW = IW + N1 +C +C MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY. + WS(IW+1) = A(I,NP1) + IW = IW + 1 + 80 CONTINUE + WS(IW+1) = ZERO + CALL DCOPY(N,WS(IW+1),0,WS(IW+1),1) + IW = IW + N + WS(IW+1) = ONE + IW = IW + 1 +C +C SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0. THE +C MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR +C F = TRANSPOSE OF (0,...,0,1). + IX = IW + 1 + IW = IW + M +C +C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF +C DWNNLS( ). + IS(1) = 0 + IS(2) = 0 + CALL DWNNLS(WS,NP1,N2,NP1-N2,M,0,PRGOPT,WS(IX),RNORM, + * MODEW,IS,WS(IW+1)) +C +C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W. + SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) + IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) + * GO TO 110 + SC = ONE/SC + DO 90 J = 1, N1 + X(J) = SC*DDOT(M,A(1,J),1,WS(IX),1) + 90 CONTINUE +C +C COMPUTE THE VECTOR Q=Y-GW. OVERWRITE Y WITH THIS +C VECTOR. + DO 100 I = 1, M + A(I,NP1) = A(I,NP1) - DDOT(N1,A(I,1),MDA,X,1) + 100 CONTINUE + GO TO 120 + 110 CONTINUE + MODE = 2 +C .........EXIT + GO TO 190 + 120 CONTINUE + 130 CONTINUE + IF (N2 .LE. 0) GO TO 180 +C +C COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*). + IW = 0 + DO 140 I = 1, M + CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) + IW = IW + N2 + WS(IW+1) = A(I,NP1) + IW = IW + 1 + 140 CONTINUE + WS(IW+1) = ZERO + CALL DCOPY(N2,WS(IW+1),0,WS(IW+1),1) + IW = IW + N2 + WS(IW+1) = ONE + IW = IW + 1 + IX = IW + 1 + IW = IW + M +C +C SOLVE RV=S SUBJECT TO V.GE.0. THE MATRIX R =(TRANSPOSE +C OF (H Q)), WHERE Q=Y-GW. THE (N2+1)-VECTOR S =(TRANSPOSE +C OF (0,...,0,1)). +C +C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF +C DWNNLS( ). + IS(1) = 0 + IS(2) = 0 + CALL DWNNLS(WS,N2+1,0,N2+1,M,0,PRGOPT,WS(IX),RNORM,MODEW, + * IS,WS(IW+1)) +C +C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z. + SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) + IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) + * GO TO 160 + SC = ONE/SC + DO 150 J = 1, N2 + L = N1 + J + X(L) = SC*DDOT(M,A(1,L),1,WS(IX),1)*X(L) + 150 CONTINUE + GO TO 170 + 160 CONTINUE + MODE = 2 +C .........EXIT + GO TO 190 + 170 CONTINUE + 180 CONTINUE +C +C ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION. + CALL DSCAL(N,YNORM,X,1) + WNORM = DNRM2(N1,X,1) + 190 CONTINUE + 200 CONTINUE + RETURN + END +*DECK DWNNLS + SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, + + IWORK, WORK) +C***BEGIN PROLOGUE DWNNLS +C***PURPOSE Solve a linearly constrained least squares problem with +C equality constraints and nonnegativity constraints on +C selected variables. +C***LIBRARY SLATEC +C***CATEGORY K1A2A +C***TYPE DOUBLE PRECISION (WNNLS-S, DWNNLS-D) +C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, +C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, +C NONNEGATIVITY CONSTRAINTS, QUADRATIC PROGRAMMING +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C Abstract +C +C This subprogram solves a linearly constrained least squares +C problem. Suppose there are given matrices E and A of +C respective dimensions ME by N and MA by N, and vectors F +C and B of respective lengths ME and MA. This subroutine +C solves the problem +C +C EX = F, (equations to be exactly satisfied) +C +C AX = B, (equations to be approximately satisfied, +C in the least squares sense) +C +C subject to components L+1,...,N nonnegative +C +C Any values ME.GE.0, MA.GE.0 and 0.LE. L .LE.N are permitted. +C +C The problem is reposed as problem DWNNLS +C +C (WT*E)X = (WT*F) +C ( A) ( B), (least squares) +C subject to components L+1,...,N nonnegative. +C +C The subprogram chooses the heavy weight (or penalty parameter) WT. +C +C The parameters for DWNNLS are +C +C INPUT.. All TYPE REAL variables are DOUBLE PRECISION +C +C W(*,*),MDW, The array W(*,*) is double subscripted with first +C ME,MA,N,L dimensioning parameter equal to MDW. For this +C discussion let us call M = ME + MA. Then MDW +C must satisfy MDW.GE.M. The condition MDW.LT.M +C is an error. +C +C The array W(*,*) contains the matrices and vectors +C +C (E F) +C (A B) +C +C in rows and columns 1,...,M and 1,...,N+1 +C respectively. Columns 1,...,L correspond to +C unconstrained variables X(1),...,X(L). The +C remaining variables are constrained to be +C nonnegative. The condition L.LT.0 or L.GT.N is +C an error. +C +C PRGOPT(*) This double precision array is the option vector. +C If the user is satisfied with the nominal +C subprogram features set +C +C PRGOPT(1)=1 (or PRGOPT(1)=1.0) +C +C Otherwise PRGOPT(*) is a linked list consisting of +C groups of data of the following form +C +C LINK +C KEY +C DATA SET +C +C The parameters LINK and KEY are each one word. +C The DATA SET can be comprised of several words. +C The number of items depends on the value of KEY. +C The value of LINK points to the first +C entry of the next group of data within +C PRGOPT(*). The exception is when there are +C no more options to change. In that +C case LINK=1 and the values KEY and DATA SET +C are not referenced. The general layout of +C PRGOPT(*) is as follows. +C +C ...PRGOPT(1)=LINK1 (link to first entry of next group) +C . PRGOPT(2)=KEY1 (key to the option change) +C . PRGOPT(3)=DATA VALUE (data value for this change) +C . . +C . . +C . . +C ...PRGOPT(LINK1)=LINK2 (link to the first entry of +C . next group) +C . PRGOPT(LINK1+1)=KEY2 (key to the option change) +C . PRGOPT(LINK1+2)=DATA VALUE +C ... . +C . . +C . . +C ...PRGOPT(LINK)=1 (no more options to change) +C +C Values of LINK that are nonpositive are errors. +C A value of LINK.GT.NLINK=100000 is also an error. +C This helps prevent using invalid but positive +C values of LINK that will probably extend +C beyond the program limits of PRGOPT(*). +C Unrecognized values of KEY are ignored. The +C order of the options is arbitrary and any number +C of options can be changed with the following +C restriction. To prevent cycling in the +C processing of the option array a count of the +C number of options changed is maintained. +C Whenever this count exceeds NOPT=1000 an error +C message is printed and the subprogram returns. +C +C OPTIONS.. +C +C KEY=6 +C Scale the nonzero columns of the +C entire data matrix +C (E) +C (A) +C to have length one. The DATA SET for +C this option is a single value. It must +C be nonzero if unit length column scaling is +C desired. +C +C KEY=7 +C Scale columns of the entire data matrix +C (E) +C (A) +C with a user-provided diagonal matrix. +C The DATA SET for this option consists +C of the N diagonal scaling factors, one for +C each matrix column. +C +C KEY=8 +C Change the rank determination tolerance from +C the nominal value of SQRT(SRELPR). This quantity +C can be no smaller than SRELPR, The arithmetic- +C storage precision. The quantity used +C here is internally restricted to be at +C least SRELPR. The DATA SET for this option +C is the new tolerance. +C +C KEY=9 +C Change the blow-up parameter from the +C nominal value of SQRT(SRELPR). The reciprocal of +C this parameter is used in rejecting solution +C components as too large when a variable is +C first brought into the active set. Too large +C means that the proposed component times the +C reciprocal of the parameter is not less than +C the ratio of the norms of the right-side +C vector and the data matrix. +C This parameter can be no smaller than SRELPR, +C the arithmetic-storage precision. +C +C For example, suppose we want to provide +C a diagonal matrix to scale the problem +C matrix and change the tolerance used for +C determining linear dependence of dropped col +C vectors. For these options the dimensions of +C PRGOPT(*) must be at least N+6. The FORTRAN +C statements defining these options would +C be as follows. +C +C PRGOPT(1)=N+3 (link to entry N+3 in PRGOPT(*)) +C PRGOPT(2)=7 (user-provided scaling key) +C +C CALL DCOPY(N,D,1,PRGOPT(3),1) (copy the N +C scaling factors from a user array called D(*) +C into PRGOPT(3)-PRGOPT(N+2)) +C +C PRGOPT(N+3)=N+6 (link to entry N+6 of PRGOPT(*)) +C PRGOPT(N+4)=8 (linear dependence tolerance key) +C PRGOPT(N+5)=... (new value of the tolerance) +C +C PRGOPT(N+6)=1 (no more options to change) +C +C +C IWORK(1), The amounts of working storage actually allocated +C IWORK(2) for the working arrays WORK(*) and IWORK(*), +C respectively. These quantities are compared with +C the actual amounts of storage needed for DWNNLS( ). +C Insufficient storage allocated for either WORK(*) +C or IWORK(*) is considered an error. This feature +C was included in DWNNLS( ) because miscalculating +C the storage formulas for WORK(*) and IWORK(*) +C might very well lead to subtle and hard-to-find +C execution errors. +C +C The length of WORK(*) must be at least +C +C LW = ME+MA+5*N +C This test will not be made if IWORK(1).LE.0. +C +C The length of IWORK(*) must be at least +C +C LIW = ME+MA+N +C This test will not be made if IWORK(2).LE.0. +C +C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION +C +C X(*) An array dimensioned at least N, which will +C contain the N components of the solution vector +C on output. +C +C RNORM The residual norm of the solution. The value of +C RNORM contains the residual vector length of the +C equality constraints and least squares equations. +C +C MODE The value of MODE indicates the success or failure +C of the subprogram. +C +C MODE = 0 Subprogram completed successfully. +C +C = 1 Max. number of iterations (equal to +C 3*(N-L)) exceeded. Nearly all problems +C should complete in fewer than this +C number of iterations. An approximate +C solution and its corresponding residual +C vector length are in X(*) and RNORM. +C +C = 2 Usage error occurred. The offending +C condition is noted with the error +C processing subprogram, XERMSG( ). +C +C User-designated +C Working arrays.. +C +C WORK(*) A double precision working array of length at least +C M + 5*N. +C +C IWORK(*) An integer-valued working array of length at least +C M+N. +C +C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for +C linear least squares problems with equality and +C nonnegativity constraints, Report SAND77-0552, Sandia +C Laboratories, June 1978. +C K. H. Haskell and R. J. Hanson, Selected algorithms for +C the linearly constrained least squares problem - a +C users guide, Report SAND78-1290, Sandia Laboratories, +C August 1979. +C K. H. Haskell and R. J. Hanson, An algorithm for +C linear least squares problems with equality and +C nonnegativity constraints, Mathematical Programming +C 21 (1981), pp. 98-118. +C R. J. Hanson and K. H. Haskell, Two algorithms for the +C linearly constrained least squares problem, ACM +C Transactions on Mathematical Software, September 1982. +C C. L. Lawson and R. J. Hanson, Solving Least Squares +C Problems, Prentice-Hall, Inc., 1974. +C***ROUTINES CALLED DWNLSM, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and revised. (WRB & RWC) +C 891006 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900510 Convert XERRWV calls to XERMSG calls, change Prologue +C comments to agree with WNNLS. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C 180613 Removed prints and replaced DP --> DOUBLE PRECISION. (THC) +C***END PROLOGUE DWNNLS + + INTEGER IWORK(*), L, L1, L2, L3, L4, L5, LIW, LW, MA, MDW, ME, + * MODE, N + DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) +C CHARACTER*8 XERN1 +C***FIRST EXECUTABLE STATEMENT DWNNLS + MODE = 0 + IF (MA+ME.LE.0 .OR. N.LE.0) RETURN +C + IF (IWORK(1).GT.0) THEN + LW = ME + MA + 5*N + IF (IWORK(1).LT.LW) THEN +C WRITE (XERN1, '(I8)') LW +C CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // +C * 'ALLOCATED FOR WORK(*), NEED LW = ' // XERN1, 2, 1) + MODE = 2 + RETURN + ENDIF + ENDIF +C + IF (IWORK(2).GT.0) THEN + LIW = ME + MA + N + IF (IWORK(2).LT.LIW) THEN +C WRITE (XERN1, '(I8)') LIW +C CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // +C * 'ALLOCATED FOR IWORK(*), NEED LIW = ' // XERN1, 2, 1) + MODE = 2 + RETURN + ENDIF + ENDIF +C + IF (MDW.LT.ME+MA) THEN +C CALL XERMSG ('SLATEC', 'DWNNLS', +C * 'THE VALUE MDW.LT.ME+MA IS AN ERROR', 1, 1) + MODE = 2 + RETURN + ENDIF +C + IF (L.LT.0 .OR. L.GT.N) THEN +C CALL XERMSG ('SLATEC', 'DWNNLS', +C * 'L.GE.0 .AND. L.LE.N IS REQUIRED', 2, 1) + MODE = 2 + RETURN + ENDIF +C +C THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS +C WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS +C REQUIRED BY THE MAIN SUBROUTINE DWNLSM( ). +C + L1 = N + 1 + L2 = L1 + N + L3 = L2 + ME + MA + L4 = L3 + N + L5 = L4 + N +C + CALL DWNLSM(W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, IWORK, + * IWORK(L1), WORK(1), WORK(L1), WORK(L2), WORK(L3), + * WORK(L4), WORK(L5)) + RETURN + END +*DECK DWNLSM + SUBROUTINE DWNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, + + IPIVOT, ITYPE, WD, H, SCALE, Z, TEMP, D) +C***BEGIN PROLOGUE DWNLSM +C***SUBSIDIARY +C***PURPOSE Subsidiary to DWNNLS +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (WNLSM-S, DWNLSM-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C This is a companion subprogram to DWNNLS. +C The documentation for DWNNLS has complete usage instructions. +C +C In addition to the parameters discussed in the prologue to +C subroutine DWNNLS, the following work arrays are used in +C subroutine DWNLSM (they are passed through the calling +C sequence from DWNNLS for purposes of variable dimensioning). +C Their contents will in general be of no interest to the user. +C +C Variables of type REAL are DOUBLE PRECISION. +C +C IPIVOT(*) +C An array of length N. Upon completion it contains the +C pivoting information for the cols of W(*,*). +C +C ITYPE(*) +C An array of length M which is used to keep track +C of the classification of the equations. ITYPE(I)=0 +C denotes equation I as an equality constraint. +C ITYPE(I)=1 denotes equation I as a least squares +C equation. +C +C WD(*) +C An array of length N. Upon completion it contains the +C dual solution vector. +C +C H(*) +C An array of length N. Upon completion it contains the +C pivot scalars of the Householder transformations performed +C in the case KRANK.LT.L. +C +C SCALE(*) +C An array of length M which is used by the subroutine +C to store the diagonal matrix of weights. +C These are used to apply the modified Givens +C transformations. +C +C Z(*),TEMP(*) +C Working arrays of length N. +C +C D(*) +C An array of length N that contains the +C column scaling for the matrix (E). +C (A) +C +C***SEE ALSO DWNNLS +C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, +C SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, +C DWNLIT, IDAMAX, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and revised. (WRB & RWC) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900328 Added TYPE section. (WRB) +C 900510 Fixed an error message. (RWC) +C 900604 DP version created from SP version. (RWC) +C 900911 Restriction on value of ALAMDA included. (WRB) +C***END PROLOGUE DWNLSM + + INTEGER IPIVOT(*), ITYPE(*), L, MA, MDW, MME, MODE, N + DOUBLE PRECISION D(*), H(*), PRGOPT(*), RNORM, SCALE(*), TEMP(*), + * W(MDW,*), WD(*), X(*), Z(*) +C + EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, SLATEC_DROTM, + * SLATEC_DROTMG, DSCAL, DSWAP, DWNLIT, IDAMAX, XERMSG + DOUBLE PRECISION D1MACH, DASUM, DNRM2 + INTEGER IDAMAX +C + DOUBLE PRECISION ALAMDA, ALPHA, ALSQ, AMAX, BLOWUP, BNORM, + * DOPE(3), DRELPR, EANORM, FAC, SM, SPARAM(5), T, TAU, WMAX, Z2, + * ZZ + INTEGER I, IDOPE(3), IMAX, ISOL, ITEMP, ITER, ITMAX, IWMAX, J, + * JCON, JP, KEY, KRANK, L1, LAST, LINK, M, ME, NEXT, NIV, NLINK, + * NOPT, NSOLN, NTIMES + LOGICAL DONE, FEASBL, FIRST, HITCON, POS +C + SAVE DRELPR, FIRST + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DWNLSM +C +C Initialize variables. +C DRELPR is the precision for the particular machine +C being used. This logic avoids resetting it every entry. +C + IF (FIRST) DRELPR = D1MACH(4) + FIRST = .FALSE. +C +C Set the nominal tolerance used in the code. +C + TAU = SQRT(DRELPR) +C + M = MA + MME + ME = MME + MODE = 2 +C +C To process option vector +C + FAC = 1.D-4 +C +C Set the nominal blow up factor used in the code. +C + BLOWUP = TAU +C +C The nominal column scaling used in the code is +C the identity scaling. +C + CALL DCOPY (N, 1.D0, 0, D, 1) +C +C Define bound for number of options to change. +C + NOPT = 1000 +C +C Define bound for positive value of LINK. +C + NLINK = 100000 + NTIMES = 0 + LAST = 1 + LINK = PRGOPT(1) + IF (LINK.LE.0 .OR. LINK.GT.NLINK) THEN +C CALL XERMSG ('SLATEC', 'DWNLSM', +C + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) + RETURN + ENDIF +C + 100 IF (LINK.GT.1) THEN + NTIMES = NTIMES + 1 + IF (NTIMES.GT.NOPT) THEN +C CALL XERMSG ('SLATEC', 'DWNLSM', +C + 'IN DWNNLS, THE LINKS IN THE OPTION VECTOR ARE CYCLING.', +C + 3, 1) + RETURN + ENDIF +C + KEY = PRGOPT(LAST+1) + IF (KEY.EQ.6 .AND. PRGOPT(LAST+2).NE.0.D0) THEN + DO 110 J = 1,N + T = DNRM2(M,W(1,J),1) + IF (T.NE.0.D0) T = 1.D0/T + D(J) = T + 110 CONTINUE + ENDIF +C + IF (KEY.EQ.7) CALL DCOPY (N, PRGOPT(LAST+2), 1, D, 1) + IF (KEY.EQ.8) TAU = MAX(DRELPR,PRGOPT(LAST+2)) + IF (KEY.EQ.9) BLOWUP = MAX(DRELPR,PRGOPT(LAST+2)) +C + NEXT = PRGOPT(LINK) + IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN +C CALL XERMSG ('SLATEC', 'DWNLSM', +C + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) + RETURN + ENDIF +C + LAST = LINK + LINK = NEXT + GO TO 100 + ENDIF +C + DO 120 J = 1,N + CALL DSCAL (M, D(J), W(1,J), 1) + 120 CONTINUE +C +C Process option vector +C + DONE = .FALSE. + ITER = 0 + ITMAX = 3*(N-L) + MODE = 0 + NSOLN = L + L1 = MIN(M,L) +C +C Compute scale factor to apply to equality constraint equations. +C + DO 130 J = 1,N + WD(J) = DASUM(M,W(1,J),1) + 130 CONTINUE +C + IMAX = IDAMAX(N,WD,1) + EANORM = WD(IMAX) + BNORM = DASUM(M,W(1,N+1),1) + ALAMDA = EANORM/(DRELPR*FAC) +C +C On machines, such as the VAXes using D floating, with a very +C limited exponent range for double precision values, the previously +C computed value of ALAMDA may cause an overflow condition. +C Therefore, this code further limits the value of ALAMDA. +C + ALAMDA = MIN(ALAMDA,SQRT(D1MACH(2))) +C +C Define scaling diagonal matrix for modified Givens usage and +C classify equation types. +C + ALSQ = ALAMDA**2 + DO 140 I = 1,M +C +C When equation I is heavily weighted ITYPE(I)=0, +C else ITYPE(I)=1. +C + IF (I.LE.ME) THEN + T = ALSQ + ITEMP = 0 + ELSE + T = 1.D0 + ITEMP = 1 + ENDIF + SCALE(I) = T + ITYPE(I) = ITEMP + 140 CONTINUE +C +C Set the solution vector X(*) to zero and the column interchange +C matrix to the identity. +C + CALL DCOPY (N, 0.D0, 0, X, 1) + DO 150 I = 1,N + IPIVOT(I) = I + 150 CONTINUE +C +C Perform initial triangularization in the submatrix +C corresponding to the unconstrained variables. +C Set first L components of dual vector to zero because +C these correspond to the unconstrained variables. +C + CALL DCOPY (L, 0.D0, 0, WD, 1) +C +C The arrays IDOPE(*) and DOPE(*) are used to pass +C information to DWNLIT(). This was done to avoid +C a long calling sequence or the use of COMMON. +C + IDOPE(1) = ME + IDOPE(2) = NSOLN + IDOPE(3) = L1 +C + DOPE(1) = ALSQ + DOPE(2) = EANORM + DOPE(3) = TAU + CALL DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM, + + IDOPE, DOPE, DONE) + ME = IDOPE(1) + KRANK = IDOPE(2) + NIV = IDOPE(3) +C +C Perform WNNLS algorithm using the following steps. +C +C Until(DONE) +C compute search direction and feasible point +C when (HITCON) add constraints +C else perform multiplier test and drop a constraint +C fin +C Compute-Final-Solution +C +C To compute search direction and feasible point, +C solve the triangular system of currently non-active +C variables and store the solution in Z(*). +C +C To solve system +C Copy right hand side into TEMP vector to use overwriting method. +C + 160 IF (DONE) GO TO 330 + ISOL = L + 1 + IF (NSOLN.GE.ISOL) THEN + CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) + DO 170 J = NSOLN,ISOL,-1 + IF (J.GT.KRANK) THEN + I = NIV - NSOLN + J + ELSE + I = J + ENDIF +C + IF (J.GT.KRANK .AND. J.LE.L) THEN + Z(J) = 0.D0 + ELSE + Z(J) = TEMP(I)/W(I,J) + CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) + ENDIF + 170 CONTINUE + ENDIF +C +C Increment iteration counter and check against maximum number +C of iterations. +C + ITER = ITER + 1 + IF (ITER.GT.ITMAX) THEN + MODE = 1 + DONE = .TRUE. + ENDIF +C +C Check to see if any constraints have become active. +C If so, calculate an interpolation factor so that all +C active constraints are removed from the basis. +C + ALPHA = 2.D0 + HITCON = .FALSE. + DO 180 J = L+1,NSOLN + ZZ = Z(J) + IF (ZZ.LE.0.D0) THEN + T = X(J)/(X(J)-ZZ) + IF (T.LT.ALPHA) THEN + ALPHA = T + JCON = J + ENDIF + HITCON = .TRUE. + ENDIF + 180 CONTINUE +C +C Compute search direction and feasible point +C + IF (HITCON) THEN +C +C To add constraints, use computed ALPHA to interpolate between +C last feasible solution X(*) and current unconstrained (and +C infeasible) solution Z(*). +C + DO 190 J = L+1,NSOLN + X(J) = X(J) + ALPHA*(Z(J)-X(J)) + 190 CONTINUE + FEASBL = .FALSE. +C +C Remove column JCON and shift columns JCON+1 through N to the +C left. Swap column JCON into the N th position. This achieves +C upper Hessenberg form for the nonactive constraints and +C leaves an upper Hessenberg matrix to retriangularize. +C + 200 DO 210 I = 1,M + T = W(I,JCON) + CALL DCOPY (N-JCON, W(I, JCON+1), MDW, W(I, JCON), MDW) + W(I,N) = T + 210 CONTINUE +C +C Update permuted index vector to reflect this shift and swap. +C + ITEMP = IPIVOT(JCON) + DO 220 I = JCON,N - 1 + IPIVOT(I) = IPIVOT(I+1) + 220 CONTINUE + IPIVOT(N) = ITEMP +C +C Similarly permute X(*) vector. +C + CALL DCOPY (N-JCON, X(JCON+1), 1, X(JCON), 1) + X(N) = 0.D0 + NSOLN = NSOLN - 1 + NIV = NIV - 1 +C +C Retriangularize upper Hessenberg matrix after adding +C constraints. +C + I = KRANK + JCON - L + DO 230 J = JCON,NSOLN + IF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.0) THEN +C +C Zero IP1 to I in column J +C + IF (W(I+1,J).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), + + W(I+1,J), SPARAM) + W(I+1,J) = 0.D0 + CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), + + MDW, SPARAM) + ENDIF + ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.1) THEN +C +C Zero IP1 to I in column J +C + IF (W(I+1,J).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), + + W(I+1,J), SPARAM) + W(I+1,J) = 0.D0 + CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), + + MDW, SPARAM) + ENDIF + ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.0) THEN + CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) + CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) + ITEMP = ITYPE(I+1) + ITYPE(I+1) = ITYPE(I) + ITYPE(I) = ITEMP +C +C Swapped row was formerly a pivot element, so it will +C be large enough to perform elimination. +C Zero IP1 to I in column J. +C + IF (W(I+1,J).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), + + W(I+1,J), SPARAM) + W(I+1,J) = 0.D0 + CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), + + MDW, SPARAM) + ENDIF + ELSEIF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.1) THEN + IF (SCALE(I)*W(I,J)**2/ALSQ.GT.(TAU*EANORM)**2) THEN +C +C Zero IP1 to I in column J +C + IF (W(I+1,J).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), + + W(I+1,J), SPARAM) + W(I+1,J) = 0.D0 + CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, + + W(I+1,J+1), MDW, SPARAM) + ENDIF + ELSE + CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) + CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) + ITEMP = ITYPE(I+1) + ITYPE(I+1) = ITYPE(I) + ITYPE(I) = ITEMP + W(I+1,J) = 0.D0 + ENDIF + ENDIF + I = I + 1 + 230 CONTINUE +C +C See if the remaining coefficients in the solution set are +C feasible. They should be because of the way ALPHA was +C determined. If any are infeasible, it is due to roundoff +C error. Any that are non-positive will be set to zero and +C removed from the solution set. +C + DO 240 JCON = L+1,NSOLN + IF (X(JCON).LE.0.D0) GO TO 250 + 240 CONTINUE + FEASBL = .TRUE. + 250 IF (.NOT.FEASBL) GO TO 200 + ELSE +C +C To perform multiplier test and drop a constraint. +C + CALL DCOPY (NSOLN, Z, 1, X, 1) + IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) +C +C Reclassify least squares equations as equalities as necessary. +C + I = NIV + 1 + 260 IF (I.LE.ME) THEN + IF (ITYPE(I).EQ.0) THEN + I = I + 1 + ELSE + CALL DSWAP (N+1, W(I,1), MDW, W(ME,1), MDW) + CALL DSWAP (1, SCALE(I), 1, SCALE(ME), 1) + ITEMP = ITYPE(I) + ITYPE(I) = ITYPE(ME) + ITYPE(ME) = ITEMP + ME = ME - 1 + ENDIF + GO TO 260 + ENDIF +C +C Form inner product vector WD(*) of dual coefficients. +C + DO 280 J = NSOLN+1,N + SM = 0.D0 + DO 270 I = NSOLN+1,M + SM = SM + SCALE(I)*W(I,J)*W(I,N+1) + 270 CONTINUE + WD(J) = SM + 280 CONTINUE +C +C Find J such that WD(J)=WMAX is maximum. This determines +C that the incoming column J will reduce the residual vector +C and be positive. +C + 290 WMAX = 0.D0 + IWMAX = NSOLN + 1 + DO 300 J = NSOLN+1,N + IF (WD(J).GT.WMAX) THEN + WMAX = WD(J) + IWMAX = J + ENDIF + 300 CONTINUE + IF (WMAX.LE.0.D0) GO TO 330 +C +C Set dual coefficients to zero for incoming column. +C + WD(IWMAX) = 0.D0 +C +C WMAX .GT. 0.D0, so okay to move column IWMAX to solution set. +C Perform transformation to retriangularize, and test for near +C linear dependence. +C +C Swap column IWMAX into NSOLN-th position to maintain upper +C Hessenberg form of adjacent columns, and add new column to +C triangular decomposition. +C + NSOLN = NSOLN + 1 + NIV = NIV + 1 + IF (NSOLN.NE.IWMAX) THEN + CALL DSWAP (M, W(1,NSOLN), 1, W(1,IWMAX), 1) + WD(IWMAX) = WD(NSOLN) + WD(NSOLN) = 0.D0 + ITEMP = IPIVOT(NSOLN) + IPIVOT(NSOLN) = IPIVOT(IWMAX) + IPIVOT(IWMAX) = ITEMP + ENDIF +C +C Reduce column NSOLN so that the matrix of nonactive constraints +C variables is triangular. +C + DO 320 J = M,NIV+1,-1 + JP = J - 1 +C +C When operating near the ME line, test to see if the pivot +C element is near zero. If so, use the largest element above +C it as the pivot. This is to maintain the sharp interface +C between weighted and non-weighted rows in all cases. +C + IF (J.EQ.ME+1) THEN + IMAX = ME + AMAX = SCALE(ME)*W(ME,NSOLN)**2 + DO 310 JP = J - 1,NIV,-1 + T = SCALE(JP)*W(JP,NSOLN)**2 + IF (T.GT.AMAX) THEN + IMAX = JP + AMAX = T + ENDIF + 310 CONTINUE + JP = IMAX + ENDIF +C + IF (W(J,NSOLN).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(JP), SCALE(J), W(JP,NSOLN), + + W(J,NSOLN), SPARAM) + W(J,NSOLN) = 0.D0 + CALL SLATEC_DROTM (N+1-NSOLN, W(JP,NSOLN+1), MDW, + + W(J,NSOLN+1), MDW, SPARAM) + ENDIF + 320 CONTINUE +C +C Solve for Z(NSOLN)=proposed new value for X(NSOLN). Test if +C this is nonpositive or too large. If this was true or if the +C pivot term was zero, reject the column as dependent. +C + IF (W(NIV,NSOLN).NE.0.D0) THEN + ISOL = NIV + Z2 = W(ISOL,N+1)/W(ISOL,NSOLN) + Z(NSOLN) = Z2 + POS = Z2 .GT. 0.D0 + IF (Z2*EANORM.GE.BNORM .AND. POS) THEN + POS = .NOT. (BLOWUP*Z2*EANORM.GE.BNORM) + ENDIF +C +C Try to add row ME+1 as an additional equality constraint. +C Check size of proposed new solution component. +C Reject it if it is too large. +C + ELSEIF (NIV.LE.ME .AND. W(ME+1,NSOLN).NE.0.D0) THEN + ISOL = ME + 1 + IF (POS) THEN +C +C Swap rows ME+1 and NIV, and scale factors for these rows. +C + CALL DSWAP (N+1, W(ME+1,1), MDW, W(NIV,1), MDW) + CALL DSWAP (1, SCALE(ME+1), 1, SCALE(NIV), 1) + ITEMP = ITYPE(ME+1) + ITYPE(ME+1) = ITYPE(NIV) + ITYPE(NIV) = ITEMP + ME = ME + 1 + ENDIF + ELSE + POS = .FALSE. + ENDIF +C + IF (.NOT.POS) THEN + NSOLN = NSOLN - 1 + NIV = NIV - 1 + ENDIF + IF (.NOT.(POS.OR.DONE)) GO TO 290 + ENDIF + GO TO 160 +C +C Else perform multiplier test and drop a constraint. To compute +C final solution. Solve system, store results in X(*). +C +C Copy right hand side into TEMP vector to use overwriting method. +C + 330 ISOL = 1 + IF (NSOLN.GE.ISOL) THEN + CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) + DO 340 J = NSOLN,ISOL,-1 + IF (J.GT.KRANK) THEN + I = NIV - NSOLN + J + ELSE + I = J + ENDIF +C + IF (J.GT.KRANK .AND. J.LE.L) THEN + Z(J) = 0.D0 + ELSE + Z(J) = TEMP(I)/W(I,J) + CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) + ENDIF + 340 CONTINUE + ENDIF +C +C Solve system. +C + CALL DCOPY (NSOLN, Z, 1, X, 1) +C +C Apply Householder transformations to X(*) if KRANK.LT.L +C + IF (KRANK.LT.L) THEN + DO 350 I = 1,KRANK + CALL DH12 (2, I, KRANK+1, L, W(I,1), MDW, H(I), X, 1, 1, 1) + 350 CONTINUE + ENDIF +C +C Fill in trailing zeroes for constrained variables not in solution. +C + IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) +C +C Permute solution vector to natural order. +C + DO 380 I = 1,N + J = I + 360 IF (IPIVOT(J).EQ.I) GO TO 370 + J = J + 1 + GO TO 360 +C + 370 IPIVOT(J) = IPIVOT(I) + IPIVOT(I) = J + CALL DSWAP (1, X(J), 1, X(I), 1) + 380 CONTINUE +C +C Rescale the solution using the column scaling. +C + DO 390 J = 1,N + X(J) = X(J)*D(J) + 390 CONTINUE +C + DO 400 I = NSOLN+1,M + T = W(I,N+1) + IF (I.LE.ME) T = T/ALAMDA + T = (SCALE(I)*T)*T + RNORM = RNORM + T + 400 CONTINUE +C + RNORM = SQRT(RNORM) + RETURN + END +*DECK DROTM + SUBROUTINE SLATEC_DROTM (N, DX, INCX, DY, INCY, DPARAM) +C***BEGIN PROLOGUE SLATEC_DROTM +C***PURPOSE Apply a modified Givens transformation. +C***LIBRARY SLATEC (BLAS) +C***CATEGORY D1A8 +C***TYPE DOUBLE PRECISION (SROTM-S, DROTM-D) +C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***DESCRIPTION +C +C B L A S Subprogram +C Description of Parameters +C +C --Input-- +C N number of elements in input vector(s) +C DX double precision vector with N elements +C INCX storage spacing between elements of DX +C DY double precision vector with N elements +C INCY storage spacing between elements of DY +C DPARAM 5-element D.P. vector. DPARAM(1) is DFLAG described below. +C Locations 2-5 of SPARAM contain elements of the +C transformation matrix H described below. +C +C --Output-- +C DX rotated vector (unchanged if N .LE. 0) +C DY rotated vector (unchanged if N .LE. 0) +C +C Apply the modified Givens transformation, H, to the 2 by N matrix +C (DX**T) +C (DY**T) , where **T indicates transpose. The elements of DX are +C in DX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else +C LX = 1+(1-N)*INCX, and similarly for DY using LY and INCY. +C +C With DPARAM(1)=DFLAG, H has one of the following forms: +C +C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 +C +C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) +C H=( ) ( ) ( ) ( ) +C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). +C +C See SLATEC_DROTMG for a description of data storage in DPARAM. +C +C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +C Krogh, Basic linear algebra subprograms for Fortran +C usage, Algorithm No. 539, Transactions on Mathematical +C Software 5, 3 (September 1979), pp. 308-323. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 791001 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920310 Corrected definition of LX in DESCRIPTION. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 180613 Renamed SLATEC_DROTM to avoid BLAS naming conflict. (THC) +C***END PROLOGUE SLATEC_DROTM + + DOUBLE PRECISION DFLAG, DH12, DH22, DX, TWO, Z, DH11, DH21, + 1 DPARAM, DY, W, ZERO + DIMENSION DX(*), DY(*), DPARAM(5) + SAVE ZERO, TWO + DATA ZERO, TWO /0.0D0, 2.0D0/ +C***FIRST EXECUTABLE STATEMENT SLATEC_DROTM + DFLAG=DPARAM(1) + IF (N.LE.0 .OR. (DFLAG+TWO.EQ.ZERO)) GO TO 140 + IF (.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 +C + NSTEPS=N*INCX +C IF (DFLAG) 50, 10, 30 +C Replaced obsolete code above with an IF-block (THC). + IF (DFLAG < 0) THEN + GO TO 50 + ELSE IF (DFLAG == 0) THEN + GO TO 10 + ELSE IF (DFLAG > 0) THEN + GO TO 30 + END IF + 10 CONTINUE + DH12=DPARAM(4) + DH21=DPARAM(3) + DO 20 I = 1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=W+Z*DH12 + DY(I)=W*DH21+Z + 20 CONTINUE + GO TO 140 + 30 CONTINUE + DH11=DPARAM(2) + DH22=DPARAM(5) + DO 40 I = 1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=W*DH11+Z + DY(I)=-W+DH22*Z + 40 CONTINUE + GO TO 140 + 50 CONTINUE + DH11=DPARAM(2) + DH12=DPARAM(4) + DH21=DPARAM(3) + DH22=DPARAM(5) + DO 60 I = 1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=W*DH11+Z*DH12 + DY(I)=W*DH21+Z*DH22 + 60 CONTINUE + GO TO 140 + 70 CONTINUE + KX=1 + KY=1 + IF (INCX .LT. 0) KX = 1+(1-N)*INCX + IF (INCY .LT. 0) KY = 1+(1-N)*INCY +C +C IF (DFLAG) 120,80,100 +C Replaced obsolete code above with an IF-block (THC). + IF (DFLAG < 0) THEN + GO TO 120 + ELSE IF (DFLAG == 0) THEN + GO TO 80 + ELSE IF (DFLAG > 0) THEN + GO TO 100 + END IF + 80 CONTINUE + DH12=DPARAM(4) + DH21=DPARAM(3) + DO 90 I = 1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=W+Z*DH12 + DY(KY)=W*DH21+Z + KX=KX+INCX + KY=KY+INCY + 90 CONTINUE + GO TO 140 + 100 CONTINUE + DH11=DPARAM(2) + DH22=DPARAM(5) + DO 110 I = 1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=W*DH11+Z + DY(KY)=-W+DH22*Z + KX=KX+INCX + KY=KY+INCY + 110 CONTINUE + GO TO 140 + 120 CONTINUE + DH11=DPARAM(2) + DH12=DPARAM(4) + DH21=DPARAM(3) + DH22=DPARAM(5) + DO 130 I = 1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=W*DH11+Z*DH12 + DY(KY)=W*DH21+Z*DH22 + KX=KX+INCX + KY=KY+INCY + 130 CONTINUE + 140 CONTINUE + RETURN + END +*DECK SLATEC_DROTMG + SUBROUTINE SLATEC_DROTMG (DD1, DD2, DX1, DY1, DPARAM) +C***BEGIN PROLOGUE SLATEC_DROTMG +C***PURPOSE Construct a modified Givens transformation. +C***LIBRARY SLATEC (BLAS) +C***CATEGORY D1B10 +C***TYPE DOUBLE PRECISION (SROTMG-S, DROTMG-D) +C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***DESCRIPTION +C +C B L A S Subprogram +C Description of Parameters +C +C --Input-- +C DD1 double precision scalar +C DD2 double precision scalar +C DX1 double precision scalar +C DX2 double precision scalar +C DPARAM D.P. 5-vector. DPARAM(1)=DFLAG defined below. +C Locations 2-5 contain the rotation matrix. +C +C --Output-- +C DD1 changed to represent the effect of the transformation +C DD2 changed to represent the effect of the transformation +C DX1 changed to represent the effect of the transformation +C DX2 unchanged +C +C Construct the modified Givens transformation matrix H which zeros +C the second component of the 2-vector (SQRT(DD1)*DX1,SQRT(DD2)* +C DY2)**T. +C With DPARAM(1)=DFLAG, H has one of the following forms: +C +C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 +C +C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) +C H=( ) ( ) ( ) ( ) +C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). +C +C Locations 2-5 of DPARAM contain DH11, DH21, DH12, and DH22, +C respectively. (Values of 1.D0, -1.D0, or 0.D0 implied by the +C value of DPARAM(1) are not stored in DPARAM.) +C +C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +C Krogh, Basic linear algebra subprograms for Fortran +C usage, Algorithm No. 539, Transactions on Mathematical +C Software 5, 3 (September 1979), pp. 308-323. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 780301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920316 Prologue corrected. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 180613 Renamed SLATEC_DROTMG to avoid BLAS naming conflict. (THC) +C***END PROLOGUE SLATEC_DROTMG + + DOUBLE PRECISION GAM, ONE, RGAMSQ, DD1, DD2, DH11, DH12, DH21, + 1 DH22, DPARAM, DP1, DP2, DQ1, DQ2, DU, DY1, ZERO, + 2 GAMSQ, DFLAG, DTEMP, DX1, TWO + DIMENSION DPARAM(5) + SAVE ZERO, ONE, TWO, GAM, GAMSQ, RGAMSQ + DATA ZERO, ONE, TWO /0.0D0, 1.0D0, 2.0D0/ + DATA GAM, GAMSQ, RGAMSQ /4096.0D0, 16777216.D0, 5.9604645D-8/ +C***FIRST EXECUTABLE STATEMENT SLATEC_DROTMG + IF (.NOT. DD1 .LT. ZERO) GO TO 10 +C GO ZERO-H-D-AND-DX1.. + GO TO 60 + 10 CONTINUE +C CASE-DD1-NONNEGATIVE + DP2=DD2*DY1 + IF (.NOT. DP2 .EQ. ZERO) GO TO 20 + DFLAG=-TWO + GO TO 260 +C REGULAR-CASE.. + 20 CONTINUE + DP1=DD1*DX1 + DQ2=DP2*DY1 + DQ1=DP1*DX1 +C + IF (.NOT. ABS(DQ1) .GT. ABS(DQ2)) GO TO 40 + DH21=-DY1/DX1 + DH12=DP2/DP1 +C + DU=ONE-DH12*DH21 +C + IF (.NOT. DU .LE. ZERO) GO TO 30 +C GO ZERO-H-D-AND-DX1.. + GO TO 60 + 30 CONTINUE + DFLAG=ZERO + DD1=DD1/DU + DD2=DD2/DU + DX1=DX1*DU +C GO SCALE-CHECK.. + GO TO 100 + 40 CONTINUE + IF (.NOT. DQ2 .LT. ZERO) GO TO 50 +C GO ZERO-H-D-AND-DX1.. + GO TO 60 + 50 CONTINUE + DFLAG=ONE + DH11=DP1/DP2 + DH22=DX1/DY1 + DU=ONE+DH11*DH22 + DTEMP=DD2/DU + DD2=DD1/DU + DD1=DTEMP + DX1=DY1*DU +C GO SCALE-CHECK + GO TO 100 +C PROCEDURE..ZERO-H-D-AND-DX1.. + 60 CONTINUE + DFLAG=-ONE + DH11=ZERO + DH12=ZERO + DH21=ZERO + DH22=ZERO +C + DD1=ZERO + DD2=ZERO + DX1=ZERO +C RETURN.. + GO TO 220 +C PROCEDURE..FIX-H.. + 70 CONTINUE + IF (.NOT. DFLAG .GE. ZERO) GO TO 90 +C + IF (.NOT. DFLAG .EQ. ZERO) GO TO 80 + DH11=ONE + DH22=ONE + DFLAG=-ONE + GO TO 90 + 80 CONTINUE + DH21=-ONE + DH12=ONE + DFLAG=-ONE + 90 CONTINUE +C GO TO IGO,(120,150,180,210) +C Replaced the above obsolete code with modern alternative (THC). + SELECT CASE(IGO) + CASE(120) + GO TO 120 + CASE(150) + GO TO 150 + CASE(180) + GO TO 180 + CASE(210) + GO TO 210 + END SELECT +C PROCEDURE..SCALE-CHECK + 100 CONTINUE + 110 CONTINUE + IF (.NOT. DD1 .LE. RGAMSQ) GO TO 130 + IF (DD1 .EQ. ZERO) GO TO 160 + IGO = 120 +C FIX-H.. + GO TO 70 + 120 CONTINUE + DD1=DD1*GAM**2 + DX1=DX1/GAM + DH11=DH11/GAM + DH12=DH12/GAM + GO TO 110 + 130 CONTINUE + 140 CONTINUE + IF (.NOT. DD1 .GE. GAMSQ) GO TO 160 + IGO = 150 +C FIX-H.. + GO TO 70 + 150 CONTINUE + DD1=DD1/GAM**2 + DX1=DX1*GAM + DH11=DH11*GAM + DH12=DH12*GAM + GO TO 140 + 160 CONTINUE + 170 CONTINUE + IF (.NOT. ABS(DD2) .LE. RGAMSQ) GO TO 190 + IF (DD2 .EQ. ZERO) GO TO 220 + IGO = 180 +C FIX-H.. + GO TO 70 + 180 CONTINUE + DD2=DD2*GAM**2 + DH21=DH21/GAM + DH22=DH22/GAM + GO TO 170 + 190 CONTINUE + 200 CONTINUE + IF (.NOT. ABS(DD2) .GE. GAMSQ) GO TO 220 + IGO = 210 +C FIX-H.. + GO TO 70 + 210 CONTINUE + DD2=DD2/GAM**2 + DH21=DH21*GAM + DH22=DH22*GAM + GO TO 200 + 220 CONTINUE +C IF (DFLAG) 250,230,240 +C Replaced obsolete code above with an IF-block (THC). + IF (DFLAG < 0) THEN + GO TO 250 + ELSE IF (DFLAG == 0) THEN + GO TO 230 + ELSE IF (DFLAG > 0) THEN + GO TO 240 + END IF + + 230 CONTINUE + DPARAM(3)=DH21 + DPARAM(4)=DH12 + GO TO 260 + 240 CONTINUE + DPARAM(2)=DH11 + DPARAM(5)=DH22 + GO TO 260 + 250 CONTINUE + DPARAM(2)=DH11 + DPARAM(3)=DH21 + DPARAM(4)=DH12 + DPARAM(5)=DH22 + 260 CONTINUE + DPARAM(1)=DFLAG + RETURN + END +*DECK DWNLIT + SUBROUTINE DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, + + RNORM, IDOPE, DOPE, DONE) +C***BEGIN PROLOGUE DWNLIT +C***SUBSIDIARY +C***PURPOSE Subsidiary to DWNNLS +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (WNLIT-S, DWNLIT-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C This is a companion subprogram to DWNNLS( ). +C The documentation for DWNNLS( ) has complete usage instructions. +C +C Note The M by (N+1) matrix W( , ) contains the rt. hand side +C B as the (N+1)st col. +C +C Triangularize L1 by L1 subsystem, where L1=MIN(M,L), with +C col interchanges. +C +C***SEE ALSO DWNNLS +C***ROUTINES CALLED DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, +C DSWAP, DWNLT1, DWNLT2, DWNLT3, IDAMAX +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and revised. (WRB & RWC) +C 890620 Revised to make WNLT1, WNLT2, and WNLT3 subroutines. (RWC) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900604 DP version created from SP version. . (RWC) +C***END PROLOGUE DWNLIT + + INTEGER IDOPE(*), IPIVOT(*), ITYPE(*), L, M, MDW, N + DOUBLE PRECISION DOPE(*), H(*), RNORM, SCALE(*), W(MDW,*) + LOGICAL DONE +C + EXTERNAL DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, + * DWNLT1, DWNLT2, DWNLT3, IDAMAX + INTEGER IDAMAX + LOGICAL DWNLT2 +C + DOUBLE PRECISION ALSQ, AMAX, EANORM, FACTOR, HBAR, RN, SPARAM(5), + * T, TAU + INTEGER I, I1, IMAX, IR, J, J1, JJ, JP, KRANK, L1, LB, LEND, ME, + * MEND, NIV, NSOLN + LOGICAL INDEP, RECALC +C +C***FIRST EXECUTABLE STATEMENT DWNLIT + ME = IDOPE(1) + NSOLN = IDOPE(2) + L1 = IDOPE(3) +C + ALSQ = DOPE(1) + EANORM = DOPE(2) + TAU = DOPE(3) +C + LB = MIN(M-1,L) + RECALC = .TRUE. + RNORM = 0.D0 + KRANK = 0 +C +C We set FACTOR=1.0 so that the heavy weight ALAMDA will be +C included in the test for column independence. +C + FACTOR = 1.D0 + LEND = L + DO 180 I=1,LB +C +C Set IR to point to the I-th row. +C + IR = I + MEND = M + CALL DWNLT1 (I, LEND, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, + + W) +C +C Update column SS and find pivot column. +C + CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) +C +C Perform column interchange. +C Test independence of incoming column. +C + 130 IF (DWNLT2(ME, MEND, IR, FACTOR, TAU, SCALE, W(1,I))) THEN +C +C Eliminate I-th column below diagonal using modified Givens +C transformations applied to (A B). +C +C When operating near the ME line, use the largest element +C above it as the pivot. +C + DO 160 J=M,I+1,-1 + JP = J-1 + IF (J.EQ.ME+1) THEN + IMAX = ME + AMAX = SCALE(ME)*W(ME,I)**2 + DO 150 JP=J-1,I,-1 + T = SCALE(JP)*W(JP,I)**2 + IF (T.GT.AMAX) THEN + IMAX = JP + AMAX = T + ENDIF + 150 CONTINUE + JP = IMAX + ENDIF +C + IF (W(J,I).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(JP), SCALE(J), W(JP,I), + + W(J,I), SPARAM) + W(J,I) = 0.D0 + CALL SLATEC_DROTM (N+1-I, W(JP,I+1), MDW, W(J,I+1), + + MDW, SPARAM) + ENDIF + 160 CONTINUE + ELSE IF (LEND.GT.I) THEN +C +C Column I is dependent. Swap with column LEND. +C Perform column interchange, +C and find column in remaining set with largest SS. +C + CALL DWNLT3 (I, LEND, M, MDW, IPIVOT, H, W) + LEND = LEND - 1 + IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 + HBAR = H(IMAX) + GO TO 130 + ELSE + KRANK = I - 1 + GO TO 190 + ENDIF + 180 CONTINUE + KRANK = L1 +C + 190 IF (KRANK.LT.ME) THEN + FACTOR = ALSQ + DO 200 I=KRANK+1,ME + CALL DCOPY (L, 0.D0, 0, W(I,1), MDW) + 200 CONTINUE +C +C Determine the rank of the remaining equality constraint +C equations by eliminating within the block of constrained +C variables. Remove any redundant constraints. +C + RECALC = .TRUE. + LB = MIN(L+ME-KRANK, N) + DO 270 I=L+1,LB + IR = KRANK + I - L + LEND = N + MEND = ME + CALL DWNLT1 (I, LEND, ME, IR, MDW, RECALC, IMAX, HBAR, H, + + SCALE, W) +C +C Update col ss and find pivot col +C + CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) +C +C Perform column interchange +C Eliminate elements in the I-th col. +C + DO 240 J=ME,IR+1,-1 + IF (W(J,I).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), + + W(J,I), SPARAM) + W(J,I) = 0.D0 + CALL SLATEC_DROTM (N+1-I, W(J-1,I+1), MDW,W(J,I+1), + + MDW, SPARAM) + ENDIF + 240 CONTINUE +C +C I=column being eliminated. +C Test independence of incoming column. +C Remove any redundant or dependent equality constraints. +C + IF (.NOT.DWNLT2(ME, MEND, IR, FACTOR,TAU,SCALE,W(1,I))) THEN + JJ = IR + DO 260 IR=JJ,ME + CALL DCOPY (N, 0.D0, 0, W(IR,1), MDW) + RNORM = RNORM + (SCALE(IR)*W(IR,N+1)/ALSQ)*W(IR,N+1) + W(IR,N+1) = 0.D0 + SCALE(IR) = 1.D0 +C +C Reclassify the zeroed row as a least squares equation. +C + ITYPE(IR) = 1 + 260 CONTINUE +C +C Reduce ME to reflect any discovered dependent equality +C constraints. +C + ME = JJ - 1 + GO TO 280 + ENDIF + 270 CONTINUE + ENDIF +C +C Try to determine the variables KRANK+1 through L1 from the +C least squares equations. Continue the triangularization with +C pivot element W(ME+1,I). +C + 280 IF (KRANK.LT.L1) THEN + RECALC = .TRUE. +C +C Set FACTOR=ALSQ to remove effect of heavy weight from +C test for column independence. +C + FACTOR = ALSQ + DO 350 I=KRANK+1,L1 +C +C Set IR to point to the ME+1-st row. +C + IR = ME+1 + LEND = L + MEND = M + CALL DWNLT1 (I, L, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, + + W) +C +C Update column SS and find pivot column. +C + CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) +C +C Perform column interchange. +C Eliminate I-th column below the IR-th element. +C + DO 320 J=M,IR+1,-1 + IF (W(J,I).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), + + W(J,I), SPARAM) + W(J,I) = 0.D0 + CALL SLATEC_DROTM (N+1-I, W(J-1,I+1), MDW, W(J,I+1), + + MDW, SPARAM) + ENDIF + 320 CONTINUE +C +C Test if new pivot element is near zero. +C If so, the column is dependent. +C Then check row norm test to be classified as independent. +C + T = SCALE(IR)*W(IR,I)**2 + INDEP = T .GT. (TAU*EANORM)**2 + IF (INDEP) THEN + RN = 0.D0 + DO 340 I1=IR,M + DO 330 J1=I+1,N + RN = MAX(RN, SCALE(I1)*W(I1,J1)**2) + 330 CONTINUE + 340 CONTINUE + INDEP = T .GT. RN*TAU**2 + ENDIF +C +C If independent, swap the IR-th and KRANK+1-th rows to +C maintain the triangular form. Update the rank indicator +C KRANK and the equality constraint pointer ME. +C + IF (.NOT.INDEP) GO TO 360 + CALL DSWAP(N+1, W(KRANK+1,1), MDW, W(IR,1), MDW) + CALL DSWAP(1, SCALE(KRANK+1), 1, SCALE(IR), 1) +C +C Reclassify the least square equation as an equality +C constraint and rescale it. +C + ITYPE(IR) = 0 + T = SQRT(SCALE(KRANK+1)) + CALL DSCAL(N+1, T, W(KRANK+1,1), MDW) + SCALE(KRANK+1) = ALSQ + ME = ME+1 + KRANK = KRANK+1 + 350 CONTINUE + ENDIF +C +C If pseudorank is less than L, apply Householder transformation. +C from right. +C + 360 IF (KRANK.LT.L) THEN + DO 370 J=KRANK,1,-1 + CALL DH12 (1, J, KRANK+1, L, W(J,1), MDW, H(J), W, MDW, 1, + + J-1) + 370 CONTINUE + ENDIF +C + NIV = KRANK + NSOLN - L + IF (L.EQ.N) DONE = .TRUE. +C +C End of initial triangularization. +C + IDOPE(1) = ME + IDOPE(2) = KRANK + IDOPE(3) = NIV + RETURN + END +*DECK DWNLT1 + SUBROUTINE DWNLT1 (I, LEND, MEND, IR, MDW, RECALC, IMAX, HBAR, H, + + SCALE, W) +C***BEGIN PROLOGUE DWNLT1 +C***SUBSIDIARY +C***PURPOSE Subsidiary to WNLIT +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (WNLT1-S, DWNLT1-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C To update the column Sum Of Squares and find the pivot column. +C The column Sum of Squares Vector will be updated at each step. +C When numerically necessary, these values will be recomputed. +C +C***SEE ALSO DWNLIT +C***ROUTINES CALLED IDAMAX +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) +C 900604 DP version created from SP version. (RWC) +C***END PROLOGUE DWNLT1 + + INTEGER I, IMAX, IR, LEND, MDW, MEND + DOUBLE PRECISION H(*), HBAR, SCALE(*), W(MDW,*) + LOGICAL RECALC +C + EXTERNAL IDAMAX + INTEGER IDAMAX +C + INTEGER J, K +C +C***FIRST EXECUTABLE STATEMENT DWNLT1 + IF (IR.NE.1 .AND. (.NOT.RECALC)) THEN +C +C Update column SS=sum of squares. +C + DO 10 J=I,LEND + H(J) = H(J) - SCALE(IR-1)*W(IR-1,J)**2 + 10 CONTINUE +C +C Test for numerical accuracy. +C + IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 + RECALC = (HBAR+1.E-3*H(IMAX)) .EQ. HBAR + ENDIF +C +C If required, recalculate column SS, using rows IR through MEND. +C + IF (RECALC) THEN + DO 30 J=I,LEND + H(J) = 0.D0 + DO 20 K=IR,MEND + H(J) = H(J) + SCALE(K)*W(K,J)**2 + 20 CONTINUE + 30 CONTINUE +C +C Find column with largest SS. +C + IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 + HBAR = H(IMAX) + ENDIF + RETURN + END +*DECK DWNLT2 + LOGICAL FUNCTION DWNLT2 (ME, MEND, IR, FACTOR, TAU, SCALE, WIC) +C***BEGIN PROLOGUE DWNLT2 +C***SUBSIDIARY +C***PURPOSE Subsidiary to WNLIT +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (WNLT2-S, DWNLT2-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C To test independence of incoming column. +C +C Test the column IC to determine if it is linearly independent +C of the columns already in the basis. In the initial tri. step, +C we usually want the heavy weight ALAMDA to be included in the +C test for independence. In this case, the value of FACTOR will +C have been set to 1.E0 before this procedure is invoked. +C In the potentially rank deficient problem, the value of FACTOR +C will have been set to ALSQ=ALAMDA**2 to remove the effect of the +C heavy weight from the test for independence. +C +C Write new column as partitioned vector +C (A1) number of components in solution so far = NIV +C (A2) M-NIV components +C And compute SN = inverse weighted length of A1 +C RN = inverse weighted length of A2 +C Call the column independent when RN .GT. TAU*SN +C +C***SEE ALSO DWNLIT +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) +C 900604 DP version created from SP version. (RWC) +C***END PROLOGUE DWNLT2 + + DOUBLE PRECISION FACTOR, SCALE(*), TAU, WIC(*) + INTEGER IR, ME, MEND +C + DOUBLE PRECISION RN, SN, T + INTEGER J +C +C***FIRST EXECUTABLE STATEMENT DWNLT2 + SN = 0.E0 + RN = 0.E0 + DO 10 J=1,MEND + T = SCALE(J) + IF (J.LE.ME) T = T/FACTOR + T = T*WIC(J)**2 +C + IF (J.LT.IR) THEN + SN = SN + T + ELSE + RN = RN + T + ENDIF + 10 CONTINUE + DWNLT2 = RN .GT. SN*TAU**2 + RETURN + END +*DECK DWNLT3 + SUBROUTINE DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) +C***BEGIN PROLOGUE DWNLT3 +C***SUBSIDIARY +C***PURPOSE Subsidiary to WNLIT +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (WNLT3-S, DWNLT3-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C Perform column interchange. +C Exchange elements of permuted index vector and perform column +C interchanges. +C +C***SEE ALSO DWNLIT +C***ROUTINES CALLED DSWAP +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) +C 900604 DP version created from SP version. (RWC) +C***END PROLOGUE DWNLT3 + + INTEGER I, IMAX, IPIVOT(*), M, MDW + DOUBLE PRECISION H(*), W(MDW,*) +C + EXTERNAL DSWAP +C + DOUBLE PRECISION T + INTEGER ITEMP +C +C***FIRST EXECUTABLE STATEMENT DWNLT3 + IF (IMAX.NE.I) THEN + ITEMP = IPIVOT(I) + IPIVOT(I) = IPIVOT(IMAX) + IPIVOT(IMAX) = ITEMP +C + CALL DSWAP(M, W(1,IMAX), 1, W(1,I), 1) +C + T = H(IMAX) + H(IMAX) = H(I) + H(I) = T + ENDIF + RETURN + END diff --git a/test/test_bin.sh b/test/test_bin.sh new file mode 100755 index 0000000..4ad2f50 --- /dev/null +++ b/test/test_bin.sh @@ -0,0 +1,46 @@ +#!/bin/bash + +# Run delsparses on 2d/4d VarSys test problems and analyze output +bin/delsparses data/varsys/sample_input2d.dat > sample_out2d.txt +if [[ `wc -l < sample_out2d.txt` == 710 ]] +then + echo The command-line executables seem to be installed correctly. + rm sample_out2d.txt +else + echo There seems to be an issue with the CL install of delaunaysparses. + echo See sample_out2d.txt for more information... + exit 1 +fi +bin/delsparses data/varsys/sample_input4d.dat > sample_out4d.txt +if [[ `wc -l < sample_out4d.txt` == 3027 ]] +then + echo The command-line executables seem to be installed correctly. + rm sample_out4d.txt +else + echo There seems to be an issue with the CL install of delaunaysparses. + echo See sample_out4d.txt for more information... + exit 1 +fi + +# Run delsparsep on 2d/4d VarSys test problems and analyze output +export OMP_NUM_THREADS=2 +bin/delsparsep data/varsys/sample_input2d.dat > sample_out2d.txt +if [[ `wc -l < sample_out2d.txt` == 710 ]] +then + echo The command-line executables seem to be installed correctly. + rm sample_out2d.txt +else + echo There seems to be an issue with the CL install of delaunaysparsep. + echo See sample_out2d.txt for more information... + exit 1 +fi +bin/delsparsep data/varsys/sample_input4d.dat > sample_out4d.txt +if [[ `wc -l < sample_out4d.txt` == 3027 ]] +then + echo The command-line executables seem to be installed correctly. + rm sample_out4d.txt +else + echo There seems to be an issue with the CL install of delaunaysparsep. + echo See sample_out4d.txt for more information... + exit 1 +fi diff --git a/test/test_c_install.c b/test/test_c_install.c new file mode 100644 index 0000000..24ee528 --- /dev/null +++ b/test/test_c_install.c @@ -0,0 +1,149 @@ +#include +#include +#include +#include "delsparse.h" + +int main() { + // Set the problem dimensions + int n = 50, d = 5, m = 10, ir = 2; + + // Generate random data in the unit cube + double data[n*d]; + for (int i = 0; i < n*d; i++) + data[i] = rand(); + + // Generate interpolation points + double interp[m*d]; + for (int i = 0; i < m*d; i++) + interp[i] = 0.25 + 0.5 * rand(); + + // Generate response values + double interp_in[n*ir]; + for (int i = 0; i < n*ir; i++) + interp_in[i] = rand(); + + // Allocate the output arrays + int simps[m*(d+1)], ierr[m]; + double weights[m*(d+1)], interp_out[m*ir], rnorm[m]; + + // Set the optional input parameters + bool chain = false, exact = true; + int ibudget = 10000, pmode = 1; + double eps = 0.00000001, extrap = 0.1; + + // Call the serial C interface with no options + c_delaunaysparses(&d, &n, data, &m, interp, simps, weights, ierr); + + // Check for errors + for (int i = 0; i < m; i++) { + if (ierr[i] > 2) { + printf("Error %i occurred while testing c_delaunaysparses" + " with no optional arguments\n\n", + ierr[i]); + return -1; + } + } + + // Call the serial C interface and compute interpolant values + c_delaunaysparses_interp(&d, &n, data, &m, interp, simps, weights, ierr, + &ir, interp_in, interp_out); + + // Check for errors + for (int i = 0; i < m; i++) { + if (ierr[i] > 2) { + printf("Error %i occurred while testing c_delaunaysparses" + " and computing interpolant values\n\n", ierr[i]); + return -1; + } + } + + // Call the serial C interface with optional inputs + c_delaunaysparses_opts(&d, &n, data, &m, interp, simps, weights, ierr, + &eps, &extrap, rnorm, &ibudget, &chain, &exact); + + // Check for errors + for (int i = 0; i < m; i++) { + if (ierr[i] > 2) { + printf("Error %i occurred while testing c_delaunaysparses" + " with optional arguments\n\n", ierr[i]); + return -1; + } + } + + // Call the serial C interface with optional inputs and interpolation + c_delaunaysparses_interp_opts(&d, &n, data, &m, interp, simps, weights, + ierr, &ir, interp_in, interp_out, &eps, + &extrap, rnorm, &ibudget, &chain, &exact); + + // Check for errors + for (int i = 0; i < m; i++) { + if (ierr[i] > 2) { + printf("Error %i occurred while testing c_delaunaysparses" + " with optional arguments and computing the interpolant\n\n", + ierr[i]); + return -1; + } + } + + + // Call the parallel C interface with no options + c_delaunaysparsep(&d, &n, data, &m, interp, simps, weights, ierr); + + // Check for errors + for (int i = 0; i < m; i++) { + if (ierr[i] > 2) { + printf("Error %i occurred while testing c_delaunaysparsep" + " with no optional arguments\n\n", + ierr[i]); + return -1; + } + } + + // Call the parallel C interface and compute interpolant values + c_delaunaysparsep_interp(&d, &n, data, &m, interp, simps, weights, ierr, + &ir, interp_in, interp_out); + + // Check for errors + for (int i = 0; i < m; i++) { + if (ierr[i] > 2) { + printf("Error %i occurred while testing c_delaunaysparsep" + " and computing interpolant values\n\n", ierr[i]); + return -1; + } + } + + // Call the parallel C interface with optional inputs + c_delaunaysparsep_opts(&d, &n, data, &m, interp, simps, weights, ierr, + &eps, &extrap, rnorm, &ibudget, &chain, &exact, + &pmode); + + // Check for errors + for (int i = 0; i < m; i++) { + if (ierr[i] > 2) { + printf("Error %i occurred while testing c_delaunaysparsep" + " with optional arguments\n\n", ierr[i]); + return -1; + } + } + + // Call the parallel C interface with optional inputs and interpolation + c_delaunaysparsep_interp_opts(&d, &n, data, &m, interp, simps, weights, + ierr, &ir, interp_in, interp_out, &eps, + &extrap, rnorm, &ibudget, &chain, &exact, + &pmode); + + // Check for errors + for (int i = 0; i < m; i++) { + if (ierr[i] > 2) { + printf("Error %i occurred while testing c_delaunaysparsep" + " with optional arguments and computing the interpolant\n\n", + ierr[i]); + return -1; + } + } + + + // If we made it this far, the build was successful + printf("The C binding installation appears to be successful.\n\n"); + return 0; +} diff --git a/src/test_install.f90 b/test/test_install.f90 similarity index 100% rename from src/test_install.f90 rename to test/test_install.f90 diff --git a/src/LICENSE b/toms1012/LICENSE similarity index 100% rename from src/LICENSE rename to toms1012/LICENSE diff --git a/src/Makefile b/toms1012/Makefile similarity index 100% rename from src/Makefile rename to toms1012/Makefile diff --git a/src/README b/toms1012/README similarity index 100% rename from src/README rename to toms1012/README diff --git a/toms1012/blas.f b/toms1012/blas.f new file mode 100644 index 0000000..df991ff --- /dev/null +++ b/toms1012/blas.f @@ -0,0 +1,2206 @@ + +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* ====================================== + + DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* Purpose: +* ============= +* +* DASUM takes the sum of the absolute values. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 3/93 to return if incx .le. 0. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,M,MP1,NINCX +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS,MOD +* .. + DASUM = 0.0D0 + DTEMP = 0.0D0 + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,6) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DTEMP + DABS(DX(I)) + END DO + IF (N.LT.6) THEN + DASUM = DTEMP + RETURN + END IF + END IF + MP1 = M + 1 + DO I = MP1,N,6 + DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) + + $ DABS(DX(I+2)) + DABS(DX(I+3)) + + $ DABS(DX(I+4)) + DABS(DX(I+5)) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + DTEMP = DTEMP + DABS(DX(I)) + END DO + END IF + DASUM = DTEMP + RETURN + END + + SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* Purpose: +* ============= +* +* DAXPY constant times a vector plus a vector. +* uses unrolled loops for increments equal to one. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DA is DOUBLE PRECISION. On entry, DA specifies the scalar alpha. +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +* +* INCY is INTEGER storage spacing between elements of DY +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (DA.EQ.0.0D0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,4) + IF (M.NE.0) THEN + DO I = 1,M + DY(I) = DY(I) + DA*DX(I) + END DO + END IF + IF (N.LT.4) RETURN + MP1 = M + 1 + DO I = MP1,N,4 + DY(I) = DY(I) + DA*DX(I) + DY(I+1) = DY(I+1) + DA*DX(I+1) + DY(I+2) = DY(I+2) + DA*DX(I+2) + DY(I+3) = DY(I+3) + DA*DX(I+3) + END DO + ELSE +* +* code for unequal increments or equal increments +* 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 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN + END + + SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* Purpose: +* ============= +* +* DCOPY copies a vector, x, to a vector, y. +* uses unrolled loops for increments equal to 1. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +* +* INCY is INTEGER storage spacing between elements of DY +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,7) + IF (M.NE.0) THEN + DO I = 1,M + DY(I) = DX(I) + END DO + IF (N.LT.7) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,7 + DY(I) = DX(I) + DY(I+1) = DX(I+1) + DY(I+2) = DX(I+2) + DY(I+3) = DX(I+3) + DY(I+4) = DX(I+4) + DY(I+5) = DX(I+5) + DY(I+6) = DX(I+6) + END DO + ELSE +* +* code for unequal increments or equal increments +* 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 I = 1,N + DY(IY) = DX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN + END + + DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* Purpose: +* ============= +* +* DDOT forms the dot product of two vectors. +* uses unrolled loops for increments equal to one. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +* +* INCY is INTEGER storage spacing between elements of DY +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + DDOT = 0.0D0 + DTEMP = 0.0D0 + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DTEMP + DX(I)*DY(I) + END DO + IF (N.LT.5) THEN + DDOT=DTEMP + RETURN + END IF + END IF + MP1 = M + 1 + DO I = MP1,N,5 + DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) + + $ DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) + END DO + ELSE +* +* code for unequal increments or equal increments +* 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 I = 1,N + DTEMP = DTEMP + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + DDOT = DTEMP + RETURN + END + + SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of +* Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB + LOGICAL NOTA,NOTB +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are +* not +* transposed and set NROWA, NCOLA and NROWB as the number of +* rows +* and columns of A and the number of rows of B +* respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + IF (NOTA) THEN + NROWA = M + NCOLA = K + ELSE + NROWA = K + NCOLA = M + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And if alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF (NOTA) THEN +* +* Form C := alpha*A*B**T + beta*C +* + DO 170 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 130 I = 1,M + C(I,J) = ZERO + 130 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 140 I = 1,M + C(I,J) = BETA*C(I,J) + 140 CONTINUE + END IF + DO 160 L = 1,K + TEMP = ALPHA*B(J,L) + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 200 J = 1,N + DO 190 I = 1,M + TEMP = ZERO + DO 180 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 180 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMM . +* + END + + SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER INCX,INCY,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* Purpose: +* ============= +* +* DGEMV performs one of the matrix-vector operations +* +* y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, +* +* where alpha and beta are scalars, x and y are vectors and A is an +* m by n matrix. +* +* Arguments: +* ========== +* +* TRANS is CHARACTER*1 +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +* +* TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. +* +* TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. +* M is INTEGER +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* +* N is INTEGER +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* +* ALPHA is DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* +* A is DOUBLE PRECISION array, dimension ( LDA, N ) +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* +* LDA is INTEGER +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* +* X is DOUBLE PRECISION array, dimension at least +* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +* Before entry, the incremented array X must contain the +* vector x. +* +* INCX is INTEGER +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* +* BETA is DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* +* Y is DOUBLE PRECISION array, dimension at least +* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY is INTEGER +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* +* Further Details: +* ===================== +* +* Level 2 Blas routine. +* The vector and matrix arguments are not referenced when N = 0, or M = 0 +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 1 + ELSE IF (M.LT.0) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + ELSE IF (INCY.EQ.0) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGEMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF (LSAME(TRANS,'N')) THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (LENX-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (LENY-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,LENY + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,LENY + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,LENY + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,LENY + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(TRANS,'N')) THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF (INCY.EQ.1) THEN + DO 60 J = 1,N + TEMP = ALPHA*X(JX) + DO 50 I = 1,M + Y(I) = Y(I) + TEMP*A(I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + DO 70 I = 1,M + Y(IY) = Y(IY) + TEMP*A(I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = ZERO + DO 90 I = 1,M + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120 J = 1,N + TEMP = ZERO + IX = KX + DO 110 I = 1,M + TEMP = TEMP + A(I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMV . +* + END + + SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of +* Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER(ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JY,KX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (M.LT.0) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGER ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (INCY.GT.0) THEN + JY = 1 + ELSE + JY = 1 - (N-1)*INCY + END IF + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + DO 10 I = 1,M + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + JY = JY + INCY + 20 CONTINUE + ELSE + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (M-1)*INCX + END IF + DO 40 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + IX = KX + DO 30 I = 1,M + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JY = JY + INCY + 40 CONTINUE + END IF +* + RETURN +* +* End of DGER . +* + END + + DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION X(*) +* .. +* +* Purpose: +* ============= +* +* DNRM2 returns the euclidean norm of a vector via the function +* name, so that +* +* DNRM2 := sqrt( x'*x ) +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* Further Details: +* ===================== +* +* -- This version written on 25-October-1982. +* Modified on 14-October-1993 to inline the call to DLASSQ. +* Sven Hammarling, Nag Ltd. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ + INTEGER IX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS,SQRT +* .. + IF (N.LT.1 .OR. INCX.LT.1) THEN + NORM = ZERO + ELSE IF (N.EQ.1) THEN + NORM = ABS(X(1)) + ELSE + SCALE = ZERO + SSQ = ONE +* The following loop is equivalent to this call to the LAPACK +* auxiliary routine: +* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) +* + DO 10 IX = 1,1 + (N-1)*INCX,INCX + IF (X(IX).NE.ZERO) THEN + ABSXI = ABS(X(IX)) + IF (SCALE.LT.ABSXI) THEN + SSQ = ONE + SSQ* (SCALE/ABSXI)**2 + SCALE = ABSXI + ELSE + SSQ = SSQ + (ABSXI/SCALE)**2 + END IF + END IF + 10 CONTINUE + NORM = SCALE*SQRT(SSQ) + END IF +* + DNRM2 = NORM + RETURN +* +* End of DNRM2. +* + END + + SUBROUTINE DSCAL(N,DA,DX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* Purpose: +* ============= +* +* DSCAL scales a vector by a constant. +* uses unrolled loops for increment equal to 1. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DA is DOUBLE PRECISION On entry, DA specifies the scalar alpha. +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 3/93 to return if incx .le. 0. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,M,MP1,NINCX +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + DX(I) = DA*DX(I) + END DO + IF (N.LT.5) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I+1) = DA*DX(I+1) + DX(I+2) = DA*DX(I+2) + DX(I+3) = DA*DX(I+3) + DX(I+4) = DA*DX(I+4) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + DX(I) = DA*DX(I) + END DO + END IF + RETURN + END + + SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* Purpose: +* ============= +* +* DSWAP interchanges two vectors. +* uses unrolled loops for increments equal to 1. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +* +* INCY is INTEGER storage spacing between elements of DY +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,3) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + END DO + IF (N.LT.3) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,3 + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + DTEMP = DX(I+1) + DX(I+1) = DY(I+1) + DY(I+1) = DTEMP + DTEMP = DX(I+2) + DX(I+2) = DY(I+2) + DY(I+2) = DTEMP + END DO + ELSE +* +* code for unequal increments or equal increments 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 I = 1,N + DTEMP = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN + END + + SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of +* Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOUNIT,UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTRMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*A*B. +* + IF (UPPER) THEN + DO 50 J = 1,N + DO 40 K = 1,M + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + DO 30 I = 1,K - 1 + B(I,J) = B(I,J) + TEMP*A(I,K) + 30 CONTINUE + IF (NOUNIT) TEMP = TEMP*A(K,K) + B(K,J) = TEMP + END IF + 40 CONTINUE + 50 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + B(K,J) = TEMP + IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) + DO 60 I = K + 1,M + B(I,J) = B(I,J) + TEMP*A(I,K) + 60 CONTINUE + END IF + 70 CONTINUE + 80 CONTINUE + END IF + ELSE +* +* Form B := alpha*A**T*B. +* + IF (UPPER) THEN + DO 110 J = 1,N + DO 100 I = M,1,-1 + TEMP = B(I,J) + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 90 K = 1,I - 1 + TEMP = TEMP + A(K,I)*B(K,J) + 90 CONTINUE + B(I,J) = ALPHA*TEMP + 100 CONTINUE + 110 CONTINUE + ELSE + DO 140 J = 1,N + DO 130 I = 1,M + TEMP = B(I,J) + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 120 K = I + 1,M + TEMP = TEMP + A(K,I)*B(K,J) + 120 CONTINUE + B(I,J) = ALPHA*TEMP + 130 CONTINUE + 140 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*A. +* + IF (UPPER) THEN + DO 180 J = N,1,-1 + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = 1,M + B(I,J) = TEMP*B(I,J) + 150 CONTINUE + DO 170 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 160 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + ELSE + DO 220 J = 1,N + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 190 I = 1,M + B(I,J) = TEMP*B(I,J) + 190 CONTINUE + DO 210 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 200 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 200 CONTINUE + END IF + 210 CONTINUE + 220 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*A**T. +* + IF (UPPER) THEN + DO 260 K = 1,N + DO 240 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + TEMP = ALPHA*A(J,K) + DO 230 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 230 CONTINUE + END IF + 240 CONTINUE + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(K,K) + IF (TEMP.NE.ONE) THEN + DO 250 I = 1,M + B(I,K) = TEMP*B(I,K) + 250 CONTINUE + END IF + 260 CONTINUE + ELSE + DO 300 K = N,1,-1 + DO 280 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + TEMP = ALPHA*A(J,K) + DO 270 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 270 CONTINUE + END IF + 280 CONTINUE + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(K,K) + IF (TEMP.NE.ONE) THEN + DO 290 I = 1,M + B(I,K) = TEMP*B(I,K) + 290 CONTINUE + END IF + 300 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRMM . +* + END + + SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of +* Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER(ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTRMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := A*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*A(I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 I = 1,J - 1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*A(I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 70 I = N,J + 1,-1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 100 J = N,1,-1 + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 90 I = J - 1,1,-1 + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + X(J) = TEMP + 100 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 120 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 110 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + A(I,J)*X(IX) + 110 CONTINUE + X(JX) = TEMP + JX = JX - INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = 1,N + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 130 I = J + 1,N + TEMP = TEMP + A(I,J)*X(I) + 130 CONTINUE + X(J) = TEMP + 140 CONTINUE + ELSE + JX = KX + DO 160 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + A(I,J)*X(IX) + 150 CONTINUE + X(JX) = TEMP + JX = JX + INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRMV . +* + END + + SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*) +* .. +* +* Purpose: +* ============= +* +* DTRSM solves one of the matrix equations +* +* op( A )*X = alpha*B, or X*op( A ) = alpha*B, +* +* where alpha is a scalar, X and B are m by n matrices, A is a unit, or +* non-unit, upper or lower triangular matrix and op( A ) is one of +* +* op( A ) = A or op( A ) = A**T. +* +* The matrix X is overwritten on B. +* +* Arguments: +* ========== +* +* SIDE is CHARACTER*1 +* On entry, SIDE specifies whether op( A ) appears on the left +* or right of X as follows: +* +* SIDE = 'L' or 'l' op( A )*X = alpha*B. +* +* SIDE = 'R' or 'r' X*op( A ) = alpha*B. +* +* UPLO is CHARACTER*1 +* On entry, UPLO specifies whether the matrix A is an upper or +* lower triangular matrix as follows: +* +* UPLO = 'U' or 'u' A is an upper triangular matrix. +* +* UPLO = 'L' or 'l' A is a lower triangular matrix. +* +* TRANSA is CHARACTER*1 +* On entry, TRANSA specifies the form of op( A ) to be used in +* the matrix multiplication as follows: +* +* TRANSA = 'N' or 'n' op( A ) = A. +* +* TRANSA = 'T' or 't' op( A ) = A**T. +* +* TRANSA = 'C' or 'c' op( A ) = A**T. +* +* DIAG is CHARACTER*1 +* On entry, DIAG specifies whether or not A is unit triangular +* as follows: +* +* DIAG = 'U' or 'u' A is assumed to be unit triangular. +* +* DIAG = 'N' or 'n' A is not assumed to be unit +* triangular. +* +* M is INTEGER +* On entry, M specifies the number of rows of B. M must be at +* least zero. +* +* N is INTEGER +* On entry, N specifies the number of columns of B. N must be +* at least zero. +* +* ALPHA is DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. When alpha is +* zero then A is not referenced and B need not be set before +* entry. +* +* A is DOUBLE PRECISION array, dimension ( LDA, k ), +* where k is m when SIDE = 'L' or 'l' +* and k is n when SIDE = 'R' or 'r'. +* Before entry with UPLO = 'U' or 'u', the leading k by k +* upper triangular part of the array A must contain the upper +* triangular matrix and the strictly lower triangular part of +* A is not referenced. +* Before entry with UPLO = 'L' or 'l', the leading k by k +* lower triangular part of the array A must contain the lower +* triangular matrix and the strictly upper triangular part of +* A is not referenced. +* Note that when DIAG = 'U' or 'u', the diagonal elements of +* A are not referenced either, but are assumed to be unity. +* +* LDA is INTEGER +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When SIDE = 'L' or 'l' then +* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +* then LDA must be at least max( 1, n ). +* +* B is DOUBLE PRECISION array, dimension ( LDB, N ) +* Before entry, the leading m by n part of the array B must +* contain the right-hand side matrix B, and on exit is +* overwritten by the solution matrix X. +* +* LDB is INTEGER +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. LDB must be at least +* max( 1, m ). +* +* Further Details: +* ===================== +* +* Level 3 Blas routine. +* +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOUNIT,UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTRSM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*inv( A )*B. +* + IF (UPPER) THEN + DO 60 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 30 I = 1,M + B(I,J) = ALPHA*B(I,J) + 30 CONTINUE + END IF + DO 50 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 40 I = 1,K - 1 + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 40 CONTINUE + END IF + 50 CONTINUE + 60 CONTINUE + ELSE + DO 100 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 70 I = 1,M + B(I,J) = ALPHA*B(I,J) + 70 CONTINUE + END IF + DO 90 K = 1,M + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 80 I = K + 1,M + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 80 CONTINUE + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form B := alpha*inv( A**T )*B. +* + IF (UPPER) THEN + DO 130 J = 1,N + DO 120 I = 1,M + TEMP = ALPHA*B(I,J) + DO 110 K = 1,I - 1 + TEMP = TEMP - A(K,I)*B(K,J) + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + B(I,J) = TEMP + 120 CONTINUE + 130 CONTINUE + ELSE + DO 160 J = 1,N + DO 150 I = M,1,-1 + TEMP = ALPHA*B(I,J) + DO 140 K = I + 1,M + TEMP = TEMP - A(K,I)*B(K,J) + 140 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + B(I,J) = TEMP + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*inv( A ). +* + IF (UPPER) THEN + DO 210 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 170 I = 1,M + B(I,J) = ALPHA*B(I,J) + 170 CONTINUE + END IF + DO 190 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + DO 180 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 180 CONTINUE + END IF + 190 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 200 I = 1,M + B(I,J) = TEMP*B(I,J) + 200 CONTINUE + END IF + 210 CONTINUE + ELSE + DO 260 J = N,1,-1 + IF (ALPHA.NE.ONE) THEN + DO 220 I = 1,M + B(I,J) = ALPHA*B(I,J) + 220 CONTINUE + END IF + DO 240 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + DO 230 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 230 CONTINUE + END IF + 240 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 250 I = 1,M + B(I,J) = TEMP*B(I,J) + 250 CONTINUE + END IF + 260 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*inv( A**T ). +* + IF (UPPER) THEN + DO 310 K = N,1,-1 + IF (NOUNIT) THEN + TEMP = ONE/A(K,K) + DO 270 I = 1,M + B(I,K) = TEMP*B(I,K) + 270 CONTINUE + END IF + DO 290 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + TEMP = A(J,K) + DO 280 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 280 CONTINUE + END IF + 290 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 300 I = 1,M + B(I,K) = ALPHA*B(I,K) + 300 CONTINUE + END IF + 310 CONTINUE + ELSE + DO 360 K = 1,N + IF (NOUNIT) THEN + TEMP = ONE/A(K,K) + DO 320 I = 1,M + B(I,K) = TEMP*B(I,K) + 320 CONTINUE + END IF + DO 340 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + TEMP = A(J,K) + DO 330 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 330 CONTINUE + END IF + 340 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 350 I = 1,M + B(I,K) = ALPHA*B(I,K) + 350 CONTINUE + END IF + 360 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRSM . +* + END + + INTEGER FUNCTION IDAMAX(N,DX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* Purpose: +* ============= +* +* IDAMAX finds the index of the first element having maximum absolute value. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of SX +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 3/93 to return if incx .le. 0. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DMAX + INTEGER I,IX +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS +* .. + IDAMAX = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + IDAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DMAX = DABS(DX(1)) + DO I = 2,N + IF (DABS(DX(I)).GT.DMAX) THEN + IDAMAX = I + DMAX = DABS(DX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + DMAX = DABS(DX(1)) + IX = IX + INCX + DO I = 2,N + IF (DABS(DX(IX)).GT.DMAX) THEN + IDAMAX = I + DMAX = DABS(DX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN + END + + LOGICAL FUNCTION LSAME(CA,CB) +* +* -- Reference BLAS level1 routine (version 3.1) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER CA,CB +* .. +* +* Purpose: +* ============= +* +* LSAME returns .TRUE. if CA is the same letter as CB regardless of +* case. +* +* Arguments: +* ========== +* +* CA is CHARACTER*1 +* CB is CHARACTER*1 +* CA and CB specify the single characters to be compared. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA,INTB,ZCODE +* .. +* +* Test if the characters are equal +* + LSAME = CA .EQ. CB + IF (LSAME) RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + ZCODE = ICHAR('Z') +* +* Use 'Z' rather than 'A' so that ASCII can be detected on Prime +* machines, on which ICHAR returns a value with bit 8 set. +* ICHAR('A') on Prime machines returns 193 which is the same as +* ICHAR('A') on an EBCDIC machine. +* + INTA = ICHAR(CA) + INTB = ICHAR(CB) +* + IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 + IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 +* + ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.129 .AND. INTA.LE.137 .OR. + + INTA.GE.145 .AND. INTA.LE.153 .OR. + + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 + IF (INTB.GE.129 .AND. INTB.LE.137 .OR. + + INTB.GE.145 .AND. INTB.LE.153 .OR. + + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 +* + ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 + IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 + END IF + LSAME = INTA .EQ. INTB +* +* RETURN +* +* End of LSAME +* + END + + SUBROUTINE XERBLA( SRNAME, INFO ) +* +* -- Reference BLAS level1 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER*(*) SRNAME + INTEGER INFO +* .. +* +* Purpose: +* ============= +* +* XERBLA is an error handler for the LAPACK routines. +* It is called by an LAPACK routine if an input parameter has an +* invalid value. A message is printed and execution stops. +* +* Installers may consider modifying the STOP statement in order to +* call system-specific exception-handling facilities. +* +* Arguments: +* ========== +* +* SRNAME is CHARACTER*(*) +* The name of the routine which called XERBLA. +* +* INFO is INTEGER +* The position of the invalid parameter in the parameter list +* of the calling routine. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM +* .. +* .. Executable Statements .. +* + WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO +* + STOP +* + 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END + diff --git a/toms1012/delsparse.f90 b/toms1012/delsparse.f90 new file mode 100644 index 0000000..b093f9a --- /dev/null +++ b/toms1012/delsparse.f90 @@ -0,0 +1,2778 @@ +MODULE REAL_PRECISION ! HOMPACK90 module for 64-bit arithmetic. +INTEGER, PARAMETER:: R8=SELECTED_REAL_KIND(13) +END MODULE REAL_PRECISION + +MODULE DELSPARSE_MOD +! This module contains the REAL_PRECISION R8 data type for 64-bit arithmetic +! and interface blocks for the DELAUNAYSPARSES and DELAUNAYSPARSEP +! subroutines for computing the Delaunay simplices containing interpolation +! points Q in R^D given data points PTS. +USE REAL_PRECISION +PUBLIC + +INTERFACE + ! Interface for serial subroutine DELAUNAYSPARSES. + SUBROUTINE DELAUNAYSPARSES( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, & + IBUDGET, CHAIN, EXACT ) + USE REAL_PRECISION, ONLY : R8 + INTEGER, INTENT(IN) :: D, N + REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) + INTEGER, INTENT(IN) :: M + REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) + INTEGER, INTENT(OUT) :: SIMPS(:,:) + REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) + INTEGER, INTENT(OUT) :: IERR(:) + REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) + REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) + INTEGER, INTENT(IN), OPTIONAL :: IBUDGET + LOGICAL, INTENT(IN), OPTIONAL :: CHAIN + LOGICAL, INTENT(IN), OPTIONAL :: EXACT + END SUBROUTINE DELAUNAYSPARSES + + ! Interface for parallel subroutine DELAUNAYSPARSEP. + SUBROUTINE DELAUNAYSPARSEP( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, & + IBUDGET, CHAIN, EXACT, PMODE ) + USE REAL_PRECISION, ONLY : R8 + INTEGER, INTENT(IN) :: D, N + REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) + INTEGER, INTENT(IN) :: M + REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) + INTEGER, INTENT(OUT) :: SIMPS(:,:) + REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) + INTEGER, INTENT(OUT) :: IERR(:) + REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) + REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) + INTEGER, INTENT(IN), OPTIONAL :: IBUDGET + LOGICAL, INTENT(IN), OPTIONAL :: CHAIN + LOGICAL, INTENT(IN), OPTIONAL :: EXACT + INTEGER, INTENT(IN), OPTIONAL :: PMODE + END SUBROUTINE DELAUNAYSPARSEP + + ! Interface for SLATEC subroutine DWNNLS. + SUBROUTINE DWNNLS( W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, & + MODE, IWORK, WORK ) + USE REAL_PRECISION, ONLY : R8 + INTEGER :: IWORK(*), L, MA, MDW, ME, MODE, N + REAL(KIND=R8) :: PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) + END SUBROUTINE DWNNLS + +END INTERFACE + +END MODULE DELSPARSE_MOD + +SUBROUTINE DELAUNAYSPARSES( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EXACT ) +! This is a serial implementation of an algorithm for efficiently performing +! interpolation in R^D via the Delaunay triangulation. The algorithm is fully +! described and analyzed in +! +! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. +! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate +! interpolation in arbitrary dimension via the Delaunay triangulation. In +! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, +! USA. Article 12, 8 pages. +! +! +! On input: +! +! D is the dimension of the space for PTS and Q. +! +! N is the number of data points in PTS. +! +! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the +! coordinates of a single data point in R^D. +! +! M is the number of interpolation points in Q. +! +! Q(1:D,1:M) is a real valued matrix with M columns, each containing the +! coordinates of a single interpolation point in R^D. +! +! +! On output: +! +! PTS and Q have been rescaled and shifted. All the data points in PTS +! are now contained in the unit hyperball in R^D, and the points in Q +! have been shifted and scaled accordingly in relation to PTS. +! +! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns +! in PTS) for the D+1 vertices of the Delaunay simplex containing each +! interpolation point in Q. +! +! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each +! point in Q as a convex combination of the D+1 corresponding vertices +! in SIMPS. +! +! IERR(1:M) contains integer valued error flags associated with the +! computation of each of the M interpolation points in Q. The error +! codes are: +! +! 00 : Succesful interpolation. +! 01 : Succesful extrapolation (up to the allowed extrapolation distance). +! 02 : This point was outside the allowed extrapolation distance; the +! corresponding entries in SIMPS and WEIGHTS contain zero values. +! +! 10 : The dimension D must be positive. +! 11 : Too few data points to construct a triangulation (i.e., N < D+1). +! 12 : No interpolation points given (i.e., M < 1). +! 13 : The first dimension of PTS does not agree with the dimension D. +! 14 : The second dimension of PTS does not agree with the number of points N. +! 15 : The first dimension of Q does not agree with the dimension D. +! 16 : The second dimension of Q does not agree with the number of +! interpolation points M. +! 17 : The first dimension of the output array SIMPS does not match the number +! of vertices needed for a D-simplex (D+1). +! 18 : The second dimension of the output array SIMPS does not match the +! number of interpolation points M. +! 19 : The first dimension of the output array WEIGHTS does not match the +! number of vertices for a a D-simplex (D+1). +! 20 : The second dimension of the output array WEIGHTS does not match the +! number of interpolation points M. +! 21 : The size of the error array IERR does not match the number of +! interpolation points M. +! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. +! 23 : The first dimension of INTERP_IN does not match the first +! dimension of INTERP_OUT. +! 24 : The second dimension of INTERP_IN does not match the number of +! data points PTS. +! 25 : The second dimension of INTERP_OUT does not match the number of +! interpolation points M. +! 26 : The budget supplied in IBUDGET does not contain a positive +! integer. +! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. +! 28 : The size of the RNORM output array does not match the number of +! interpolation points M. +! +! 30 : Two or more points in the data set PTS are too close together with +! respect to the working precision (EPS), which would result in a +! numerically degenerate simplex. +! 31 : All the data points in PTS lie in some lower dimensional linear +! manifold (up to the working precision), and no valid triangulation +! exists. +! 40 : An error caused DELAUNAYSPARSES to terminate before this value could +! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may +! contain garbage values. +! +! 50 : A memory allocation error occurred while allocating the work array +! WORK. +! +! 60 : The budget was exceeded before the algorithm converged on this +! value. If the dimension is high, try increasing IBUDGET. This +! error can also be caused by a working precision EPS that is too +! small for the conditioning of the problem. +! +! 61 : A value that was judged appropriate later caused LAPACK to encounter a +! singularity. Try increasing the value of EPS. +! +! 70 : Allocation error for the extrapolation work arrays. +! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection +! of an extrapolation point onto the convex hull. +! 72 : The SLATEC subroutine DWNNLS has reported a usage error. +! +! The errors 72, 80--83 should never occur, and likely indicate a +! compiler bug or hardware failure. +! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. +! 81 : The LAPACK subroutine DGETRF has reported an illegal value. +! 82 : The LAPACK subroutine DGETRS has reported an illegal value. +! 83 : The LAPACK subroutine DORMQR has reported an illegal value. +! +! +! Optional arguments: +! +! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of +! the data points in PTS on input. The first dimension of INTERP_IN is +! inferred to be the dimension of these response vectors, and the +! second dimension must match N. If present, the response values will +! be computed for each interpolation point in Q, and stored in INTERP_OUT, +! which therefore must also be present. If both INTERP_IN and INTERP_OUT +! are omitted, only the containing simplices and convex combination +! weights are returned. +! +! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each +! interpolation point in Q on output. The first dimension of INTERP_OUT +! must match the first dimension of INTERP_IN, and the second dimension +! must match M. If present, the response values at each interpolation +! point are computed as a convex combination of the response values +! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing +! that interpolation point. Therefore, if INTERP_OUT is present, then +! INTERP_IN must also be present. If both are omitted, only the +! simplices and convex combination weights are returned. +! +! EPS contains the real working precision for the problem on input. By default, +! EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff for the +! machine. In general, any values that differ by less than EPS are judged +! as equal, and any weights that are greater than -EPS are judged as +! nonnegative. EPS cannot take a value less than the default value of +! \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, the default +! value will be used instead automatically. +! +! EXTRAP contains the real maximum extrapolation distance (relative to the +! diameter of PTS) on input. Interpolation at a point outside the convex +! hull of PTS is done by projecting that point onto the convex hull, and +! then doing normal Delaunay interpolation at that projection. +! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) +! units outside the convex hull of PTS will not be done and an error code +! of 2 will be returned. Note that computing the projection can be +! expensive. Setting EXTRAP=0 will cause all extrapolation points to be +! ignored without ever computing a projection. By default, EXTRAP=0.1 +! (extrapolate by up to 10% of the diameter of PTS). +! +! RNORM(1:M) contains the real unscaled projection (2-norm) distances from +! any projection computations on output. If not present, these distances +! are still computed for each extrapolation point, but are never returned. +! +! IBUDGET on input contains the integer budget for performing flips while +! iterating toward the simplex containing each interpolation point in +! Q. This prevents DELAUNAYSPARSES from falling into an infinite loop when +! an inappropriate value of EPS is given with respect to the problem +! conditioning. By default, IBUDGET=50000. However, for extremely +! high-dimensional problems and pathological inputs, the default value +! may be insufficient. +! +! CHAIN is a logical input argument that determines whether a new first +! simplex should be constructed for each interpolation point +! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." +! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not +! recommended, unless the size of the triangulation is relatively small +! or the interpolation points are known to be tightly clustered. +! +! EXACT is a logical input argument that determines whether the exact +! diameter should be computed and whether a check for duplicate data +! points should be performed in advance. When EXACT=.FALSE., the +! diameter of PTS is approximated by twice the distance from the +! barycenter of PTS to the farthest point in PTS, and no check is +! done to find the closest pair of points, which could result in hard +! to find bugs later on. When EXACT=.TRUE., the exact diameter is +! computed and an error is returned whenever PTS contains duplicate +! values up to the precision EPS. By default EXACT=.TRUE., but setting +! EXACT=.FALSE. could result in significant speedup when N is large. +! It is strongly recommended that most users leave EXACT=.TRUE., as +! setting EXACT=.FALSE. could result in input errors that are difficult +! to identify. Also, the diameter approximation could be wrong by up to +! a factor of two. +! +! +! Subroutines and functions directly referenced from BLAS are +! DDOT, DGEMV, DNRM2, DTRSM, +! and from LAPACK are +! DGEQP3, DGETRF, DGETRS, DORMQR. +! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its +! SLATEC dependencies have been slightly edited to comply with the Fortran +! 2008 standard, with all print statements and references to stderr being +! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 +! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS +! Algorithm 777) is used for the real data type. The REAL_PRECISION module, +! DELAUNAYSPARSES, and DWNNLS and its dependencies comply with the Fortran +! 2008 standard. +! +! Primary Author: Tyler H. Chang +! Last Update: March, 2020 +! +USE REAL_PRECISION, ONLY : R8 +IMPLICIT NONE + +! Input arguments. +INTEGER, INTENT(IN) :: D, N +REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) ! Rescaled on output. +INTEGER, INTENT(IN) :: M +REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) ! Rescaled on output. +! Output arguments. +INTEGER, INTENT(OUT) :: SIMPS(:,:) +REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) +INTEGER, INTENT(OUT) :: IERR(:) +! Optional arguments. +REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) +REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) +REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP +REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) +INTEGER, INTENT(IN), OPTIONAL :: IBUDGET +LOGICAL, INTENT(IN), OPTIONAL :: CHAIN +LOGICAL, INTENT(IN), OPTIONAL :: EXACT + +! Local copies of optional input arguments. +REAL(KIND=R8) :: EPSL, EXTRAPL +INTEGER :: IBUDGETL +LOGICAL :: CHAINL, EXACTL + +! Local variables. +INTEGER :: I, J, K ! Loop iteration variables. +INTEGER :: IEXTRAPS ! Extrapolation budget. +INTEGER :: ITMP, JTMP ! Temporary variables for swapping, looping, etc. +INTEGER :: LWORK ! Size of the work array. +INTEGER :: MI ! Index of current interpolation point. +REAL(KIND=R8) :: CURRRAD ! Radius of the current circumsphere. +REAL(KIND=R8) :: MINRAD ! Minimum circumsphere radius observed. +REAL(KIND=R8) :: PTS_DIAM ! Scaled diameter of data set. +REAL(KIND=R8) :: PTS_SCALE ! Data scaling factor. +REAL(KIND=R8) :: RNORML ! Euclidean norm of the projection residual. +REAL(KIND=R8) :: SIDE1, SIDE2 ! Signs (+/-1) denoting sides of a facet. + +! Local arrays, requiring O(d^2) additional memory. +INTEGER :: IPIV(D) ! Pivot indices. +INTEGER :: SEED(D+1) ! Copy of the SEED simplex. Only used if CHAIN = .TRUE. +REAL(KIND=R8) :: AT(D,D) ! The transpose of A, the linear coefficient matrix. +REAL(KIND=R8) :: B(D) ! The RHS of a linear system. +REAL(KIND=R8) :: CENTER(D) ! The circumcenter of a simplex. +REAL(KIND=R8) :: LQ(D,D) ! Holds LU or QR factorization of AT. +REAL(KIND=R8) :: PLANE(D+1) ! The hyperplane containing a facet. +REAL(KIND=R8) :: PRGOPT_DWNNLS(1) ! Options array for DWNNLS. +REAL(KIND=R8) :: PROJ(D) ! The projection of the current iterate. +REAL(KIND=R8) :: TAU(D) ! Householder reflector constants. +REAL(KIND=R8) :: X(D) ! The solution to a linear system. + +! Extrapolation work arrays are only allocated if DWNNLS is called. +INTEGER, ALLOCATABLE :: IWORK_DWNNLS(:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: W_DWNNLS(:,:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: WORK(:) ! Allocated with size LWORK. +REAL(KIND=R8), ALLOCATABLE :: WORK_DWNNLS(:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: X_DWNNLS(:) ! Only for DWNNLS. + +! External functions and subroutines. +REAL(KIND=R8), EXTERNAL :: DDOT ! Inner product (BLAS). +REAL(KIND=R8), EXTERNAL :: DNRM2 ! Euclidean norm (BLAS). +EXTERNAL :: DGEMV ! General matrix vector multiply (BLAS) +EXTERNAL :: DGEQP3 ! Perform a QR factorization with column pivoting (LAPACK). +EXTERNAL :: DGETRF ! Perform a LU factorization with partial pivoting (LAPACK). +EXTERNAL :: DGETRS ! Use the output of DGETRF to solve a linear system (LAPACK). +EXTERNAL :: DORMQR ! Apply householder reflectors to a matrix (LAPACK). +EXTERNAL :: DTRSM ! Perform a triangular solve (BLAS). +EXTERNAL :: DWNNLS ! Solve an inequality constrained least squares problem + ! (SLATEC). + +! Check for input size and dimension errors. +IF (D < 1) THEN ! The dimension must satisfy D > 0. + IERR(:) = 10; RETURN; END IF +IF (N < D+1) THEN ! Must have at least D+1 data points. + IERR(:) = 11; RETURN; END IF +IF (M < 1) THEN ! Must have at least one interpolation point. + IERR(:) = 12; RETURN; END IF +IF (SIZE(PTS,1) .NE. D) THEN ! Dimension of PTS array should match. + IERR(:) = 13; RETURN; END IF +IF (SIZE(PTS,2) .NE. N) THEN ! Number of data points should match. + IERR(:) = 14; RETURN; END IF +IF (SIZE(Q,1) .NE. D) THEN ! Dimension of Q should match. + IERR(:) = 15; RETURN; END IF +IF (SIZE(Q,2) .NE. M) THEN ! Number of interpolation points should match. + IERR(:) = 16; RETURN; END IF +IF (SIZE(SIMPS,1) .NE. D+1) THEN ! Need space for D+1 vertices per simplex. + IERR(:) = 17; RETURN; END IF +IF (SIZE(SIMPS,2) .NE. M) THEN ! There will be M output simplices. + IERR(:) = 18; RETURN; END IF +IF (SIZE(WEIGHTS,1) .NE. D+1) THEN ! There will be D+1 weights per simplex. + IERR(:) = 19; RETURN; END IF +IF (SIZE(WEIGHTS,2) .NE. M) THEN ! One vector of weights per simplex. + IERR(:) = 20; RETURN; END IF +IF (SIZE(IERR) .NE. M) THEN ! An error flag for each interpolation point. + IERR(:) = 21; RETURN; END IF + +! Check for optional arguments. +IF (PRESENT(INTERP_IN) .NEQV. PRESENT(INTERP_OUT)) THEN + IERR(:) = 22; RETURN; END IF +IF (PRESENT(INTERP_IN)) THEN ! Sizes must agree. + IF (SIZE(INTERP_IN,1) .NE. SIZE(INTERP_OUT,1)) THEN + IERR(:) = 23 ; RETURN; END IF + IF(SIZE(INTERP_IN,2) .NE. N) THEN + IERR(:) = 24; RETURN; END IF + IF (SIZE(INTERP_OUT,2) .NE. M) THEN + IERR(:) = 25; RETURN; END IF + INTERP_OUT(:,:) = 0.0_R8 ! Initialize output to zeros. +END IF +EPSL = SQRT(EPSILON(0.0_R8)) ! Get the machine unit roundoff constant. +IF (PRESENT(EPS)) THEN + IF (EPSL < EPS) THEN ! If the given precision is too small, ignore it. + EPSL = EPS + END IF +END IF +IF (PRESENT(IBUDGET)) THEN + IBUDGETL = IBUDGET ! Use the given budget if present. + IF (IBUDGETL < 1) THEN + IERR(:) = 26; RETURN; END IF +ELSE + IBUDGETL = 50000 ! Default value for budget. +END IF +IF (PRESENT(EXTRAP)) THEN + EXTRAPL = EXTRAP + IF (EXTRAPL < 0) THEN ! Check that the extrapolation distance is legal. + IERR(:) = 27; RETURN; END IF +ELSE + EXTRAPL = 0.1_R8 ! Default extrapolation distance (for normalized points). +END IF +IF (PRESENT(RNORM)) THEN + IF (SIZE(RNORM,1) .NE. M) THEN ! The length of the array must match. + IERR(:) = 28; RETURN; END IF + RNORM(:) = 0.0_R8 ! Initialize output to zeros. +END IF +IF (PRESENT(CHAIN)) THEN + CHAINL = CHAIN ! Turn chaining on, if necessarry. + SEED(:) = 0 ! Initialize SEED in case it is needed. +ELSE + CHAINL = .FALSE. +END IF +IF (PRESENT(EXACT)) THEN + EXACTL = EXACT ! Set error checking and exact diameter computations. +ELSE + EXACTL = .TRUE. +END IF + +! Scale and center the data points and interpolation points. +CALL RESCALE(MINRAD, PTS_DIAM, PTS_SCALE) +IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. + IERR(:) = 30; RETURN; END IF + +! Query DGEQP3 for optimal work array size (LWORK). +LWORK = -1 +CALL DGEQP3(D,D,LQ,D,IPIV,TAU,B,LWORK,IERR(1)) +LWORK = INT(B(1)) ! Compute the optimal work array size. +ALLOCATE(WORK(LWORK), STAT=I) ! Allocate WORK to size LWORK. +IF (I .NE. 0) THEN ! Check for memory allocation errors. + IERR(:) = 50; RETURN; END IF + +! Initialize all error codes to "TBD" values. +IERR(:) = 40 + +! Outer loop over all interpolation points (in Q). +OUTER : DO MI = 1, M + + ! Check if this interpolation point was already found. + IF (IERR(MI) .EQ. 0) CYCLE OUTER + + ! Initialize the projection and reset the residual. + PROJ(:) = Q(:,MI) + RNORML = 0.0_R8 + + ! Check if extrapolation is enabled. + IF (EXTRAPL < EPSL) THEN + IEXTRAPS = -1 ! If not, set the extrapolation budget negative. + ELSE + IEXTRAPS = 1 ! Allow for exactly one projection for this point. + END IF + + ! If there is no useable seed or if chaining is turned off, then make a new + ! simplex. + IF( (.NOT. CHAINL) .OR. SEED(1) .EQ. 0) THEN + CALL MAKEFIRSTSIMP() + IF(IERR(MI) .NE. 0) CYCLE OUTER + ! Otherwise, use the seed. + ELSE + ! Copy the seed to the current simplex. + SIMPS(:,MI) = SEED(:) + ! Rebuild the linear system. + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + + ! Inner loop searching for a simplex containing the point Q(:,MI). + INNER : DO K = 1, IBUDGETL + + ! If chaining is on, save each good simplex as the next seed. + IF (CHAINL) SEED(:) = SIMPS(:,MI) + + ! Check if the current simplex contains Q(:,MI). + IF (PTINSIMP()) EXIT INNER + IF (IERR(MI) .NE. 0) CYCLE OUTER ! Check for an error flag. + + ! Swap out the least weighted vertex, but save its value in case it + ! needs to be restored later. + JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) + ITMP = SIMPS(JTMP,MI) + SIMPS(JTMP,MI) = SIMPS(D+1,MI) + + ! If the least weighted vertex (index JTMP) is not the first vertex, + ! then just drop row (JTMP-1) from the linear system (corresponding + ! to column (JTMP-1) of A^T). + IF(JTMP .NE. 1) THEN + AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) + ! However, if JTMP = 1, then both A^T and B must be reconstructed. + ELSE + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + + ! Compute the next simplex (do one flip). + CALL MAKESIMPLEX() + IF (IERR(MI) .NE. 0) CYCLE OUTER + + ! If no vertex was found, then this is an extrapolation point. + IF (SIMPS(D+1,MI) .EQ. 0) THEN + + ! If extrapolation is not allowed (EXTRAP=0), do not proceed. + IF (IEXTRAPS < 0) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! Set the error flag and skip this point. + IERR(MI) = 2; CYCLE OUTER + + ! If extrapolation is allowed (EXTRAP>0), check the budget. + ELSE IF (IEXTRAPS .EQ. 0) THEN + ! A second projection has been attempted. This code is rarely + ! called, except in extreme cases involving nearly singular + ! simplices near the convex hull of P. + + ! Swap the weights to match the simplex indices, and zero the + ! most negative weight. + WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) + WEIGHTS(D+1,MI) = 0.0_R8 + ! Loop through all the remaining facets from which Q(:,MI) is + ! visible, and attempt to flip across each one. + DO WHILE (SIMPS(D+1,MI) .EQ. 0) + ! Restore the previous simplex and linear system. + SIMPS(D+1,MI) = ITMP + AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + ! Find the next most negative weight. + JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) + ! Check if WEIGHTS(JTMP,MI) .GE. 0. + IF (WEIGHTS(JTMP,MI) .GE. -EPSL) THEN + ! There is no other direction to flip, so Q(:,MI) must be + ! within EPSL of the current simplex. + ! Project Q(:,MI) onto the current simplex. + + ! Since at least one projection has already been done, + ! the work arrays have already been allocated. + PRGOPT_DWNNLS(1) = 1.0_R8 + IWORK_DWNNLS(1) = 6*D + 6 + IWORK_DWNNLS(2) = 2*D + 2 + ! Set equality constraint. + W_DWNNLS(1,1:D+2) = 1.0_R8 + ! Populate LS coefficient matrix and RHS. + FORALL (I=1:D+1) W_DWNNLS(2:D+1,I) = PTS(:,SIMPS(I,MI)) + W_DWNNLS(2:D+1,D+2) = PROJ(:) + ! Project onto the current simplex. + CALL DWNNLS(W_DWNNLS, D+1, 1, D, D+1, 0, PRGOPT_DWNNLS, & + WEIGHTS(:,MI), WORK(1), IERR(MI), IWORK_DWNNLS, & + WORK_DWNNLS) + IF (IERR(MI) .EQ. 1) THEN ! Failure to converge. + IERR(MI) = 71; CYCLE OUTER + ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. + IERR(MI) = 72; CYCLE OUTER + END IF + ! A solution has been found; return it. + EXIT INNER + END IF + ! Otherwise, swap the vertices. + ITMP = SIMPS(JTMP,MI) + SIMPS(JTMP,MI) = SIMPS(D+1,MI) + ! Swap the weights to match, and zero the most negative weight. + WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) + WEIGHTS(D+1,MI) = 0.0_R8 + ! If the least weighted vertex (index JTMP) is not the first + ! vertex, then just drop row (JTMP-1) from the linear system + ! (corresponding to column (JTMP-1) of A^T). + IF (JTMP .NE. 1) THEN + AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) + ! However, if JTMP=1, then both A^T and B must be reconstructed. + ELSE + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + ! Compute another simplex (try to flip again). + CALL MAKESIMPLEX(); IF (IERR(MI) .NE. 0) CYCLE OUTER + END DO + ! If the loop terminates, then a good direction was found. + ! Resume the visibility walk as normal. + CYCLE INNER + END IF + + ! Otherwise, project the extrapolation point onto the convex hull. + CALL PROJECT() + IF (IERR(MI) .NE. 0) CYCLE OUTER + + ! Check the value of RNORML for over-extrapolation. + IF (RNORML > EXTRAPL * PTS_DIAM) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! If present, record the unscaled RNORM output. + IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE + ! Set the error flag and skip this point. + IERR(MI) = 2; CYCLE OUTER + END IF + + ! Otherwise, restore the previous simplex and continue with the + ! projected value. + SIMPS(D+1,MI) = ITMP + AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + IEXTRAPS = IEXTRAPS - 1 ! Decrement the budget. + END IF + + ! End of inner loop for finding each interpolation point. + END DO INNER + + ! Check for budget violation conditions. + IF (K > IBUDGETL) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! Set the error flag and skip this point. + IERR(MI) = 60; CYCLE OUTER + END IF + + ! If the residual is nonzero, set the extrapolation flag. + IF (RNORML > EPSL) IERR(MI) = 1 + + ! If present, record the RNORM output. + IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE + +END DO OUTER ! End of outer loop over all interpolation points. + +! If INTERP_IN and INTERP_OUT are present, compute all values f(q). +IF (PRESENT(INTERP_IN)) THEN + ! Loop over all interpolation points. + DO MI = 1, M + ! Check for errors. + IF (IERR(MI) .LE. 1) THEN + ! Compute the weighted sum of vertex response values. + DO K = 1, D+1 + INTERP_OUT(:,MI) = INTERP_OUT(:,MI) & + + INTERP_IN(:,SIMPS(K,MI)) * WEIGHTS(K,MI) + END DO + END IF + END DO +END IF + +! Free dynamic work arrays. +DEALLOCATE(WORK) +IF (ALLOCATED(IWORK_DWNNLS)) DEALLOCATE(IWORK_DWNNLS) +IF (ALLOCATED(WORK_DWNNLS)) DEALLOCATE(WORK_DWNNLS) +IF (ALLOCATED(W_DWNNLS)) DEALLOCATE(W_DWNNLS) +IF (ALLOCATED(X_DWNNLS)) DEALLOCATE(X_DWNNLS) + +RETURN + +CONTAINS ! Internal subroutines and functions. + +SUBROUTINE MAKEFIRSTSIMP() +! Iteratively construct the first simplex by choosing points that +! minimize the radius of the smallest circumball. Let P_1, P_2, ..., P_K +! denote the current set of vertices for the simplex. Let P* denote the +! candidate vertex to be added to the simplex. Let CENTER denote the +! circumcenter of the simplex. Then +! +! X = CENTER - P_1 +! +! is given by the minimum norm solution to the underdetermined linear system +! +! A X = B, where +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_K - P_1, P* - P_1 ] and +! B = [ /2, /2, ..., /2 ]^T. +! +! Then the radius of the smallest circumsphere is CURRRAD = \| X \|, +! and the next vertex is given by P_{K+1} = argmin_{P*} CURRRAD, where P* +! ranges over points in PTS that are not already a vertex of the simplex. +! +! On output, this subroutine fully populates the matrix A^T and vector B, +! and fills SIMPS(:,MI) with the indices of a valid Delaunay simplex. + +! Find the first point, i.e., the closest point to Q(:,MI). +SIMPS(:,MI) = 0 +MINRAD = HUGE(0.0_R8) +DO I = 1, N + ! Check the distance to Q(:,MI). + CURRRAD = DNRM2(D, PTS(:,I) - PROJ(:), 1) + IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(1,MI) = I; END IF +END DO +! Find the second point, i.e., the closest point to PTS(:,SIMPS(1,MI)). +MINRAD = HUGE(0.0_R8) +DO I = 1, N + ! Skip repeated vertices. + IF (I .EQ. SIMPS(1,MI)) CYCLE + ! Check the diameter of the resulting circumsphere. + CURRRAD = DNRM2(D, PTS(:,I)-PTS(:,SIMPS(1,MI)), 1) + IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(2,MI) = I; END IF +END DO +IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. + IERR(MI) = 30; RETURN; END IF +! Set up the first row of the linear system. +AT(:,1) = PTS(:,SIMPS(2,MI)) - PTS(:,SIMPS(1,MI)) +B(1) = DDOT(D, AT(:,1), 1, AT(:,1), 1) / 2.0_R8 +! Loop to collect the remaining D-1 vertices for the first simplex. +DO I = 2, D + ! For numerical stability, refactor A^T P = Q R for the next iteration. + LQ(:,1:I-1) = AT(:,1:I-1) + CALL DGEQP3(D, I-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 80; RETURN + END IF + ! Set the RHS to P^T B. + FORALL (ITMP = 1:I-1) X(ITMP) = B(IPIV(ITMP)) + ! Solve R^T Q^T X = P^T B for Q^T X, and save for later. + CALL DTRSM('L', 'U', 'T', 'N', I-1, 1, 1.0_R8, LQ, D, X, D) + ! Make a copy for computing the current center. + CENTER(1:I-1) = X(1:I-1) + CENTER(I:D) = 0.0_R8 + ! Apply Q from the left. + CALL DORMQR('L', 'N', D, 1, I-1, LQ, D, TAU, CENTER, D, WORK, & + LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 83; RETURN + END IF + CENTER = CENTER + PTS(:,SIMPS(1,MI)) + ! Re-initialize the radius for each iteration. + MINRAD = HUGE(0.0_R8) + ! Check each point P* in PTS. + DO J = 1, N + ! Check that this point is not already in the simplex. + IF (ANY(SIMPS(:,MI) .EQ. J)) CYCLE + ! If PTS(:,J) is more than twice MINRAD from CENTER, do a quick skip. + IF (DNRM2(D, CENTER - PTS(:,J), 1) > 2.0_R8 * MINRAD) CYCLE + ! Perform a rank-1 update to the current QR factorization of A^T by + ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI)) by Q^T and storing in the + ! final column of R. + LQ(:,I) = PTS(:,J) - PTS(:,SIMPS(1,MI)) + CALL DORMQR('L', 'T', D, 1, I-1, LQ(:,1:I-1), D, TAU, LQ(:,I), D, & + WORK, LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 83; RETURN + END IF + ! Implicitly apply the next Householder reflector. + LQ(I,I) = DNRM2(D+1-I, LQ(I:D,I), 1) + IF (LQ(I,I) < EPSL) THEN ! A is rank-deficient. + CYCLE ! If rank-deficient, skip this point. + END IF + ! Update the current radius by \| Q^T X \| = \| X \|. + WORK(1:I-1) = (LQ(1:I-1,I) / 2.0_R8) - X(1:I-1) + WORK(I) = LQ(I,I) / 2.0_R8 + X(I) = DDOT(I, LQ(1:I,I), 1, WORK(1:I), 1) / LQ(I,I) + CURRRAD = DNRM2(I, X(1:I), 1) + ! Compare the last component of Q^T X to the current minimum. + IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(I+1,MI) = J; END IF + END DO + ! Check that a point was found. If not, then all the points must lie in a + ! lower dimensional linear manifold (error case). + IF (SIMPS(I+1,MI) .EQ. 0) THEN; IERR(MI) = 31; RETURN; END IF + ! If all operations were successful, add the best P* to the linear system. + AT(:,I) = PTS(:,SIMPS(I+1,MI)) - PTS(:,SIMPS(1,MI)) + B(I) = DDOT(D, AT(:,I), 1, AT(:,I), 1) / 2.0_R8 +END DO +IERR(MI) = 0 ! Set error flag to 'success' for a normal return. +RETURN +END SUBROUTINE MAKEFIRSTSIMP + +SUBROUTINE MAKESIMPLEX() +! Given a Delaunay facet F whose containing hyperplane does not contain +! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' +! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F +! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the +! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly +! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing +! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices +! P_1, P_2, ..., P_D, P*. Then +! +! X = CENTER - P_1 +! +! is given by the solution to the nonsingular linear system +! +! A X = B where +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and +! B = [ /2, /2, ..., /2 ]^T. +! +! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the +! candidate P* that satisfies both of the following: +! +! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) +! must be on the same side of PLANE. +! +! 2) The circumball about CENTER must not contain any points in PTS in its +! interior (Delaunay property). +! +! The above are necessary and sufficient conditions for flipping the +! Delaunay simplex, given that F is indeed a Delaunay facet. +! +! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices +! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex +! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and +! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were +! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an +! extrapolation point (not a convex combination of points in PTS). + +! Compute the hyperplane PLANE. +CALL MAKEPLANE() +IF(IERR(MI) .NE. 0) RETURN ! Check for errors. +! Compute the sign for the side of PLANE containing Q(:,MI). +SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) +SIDE1 = SIGN(1.0_R8,SIDE1) +! Initialize the center, radius, and simplex. +SIMPS(D+1,MI) = 0 +CENTER(:) = 0.0_R8 +MINRAD = HUGE(0.0_R8) +! If D=1, just check for the closest point on SIDE1 of PTS(:,SIMPS(1,MI)). +IF (D .EQ. 1) THEN + ! Loop through all points P* in PTS. + DO I = 1, N + ! Check that P* is on the appropriate halfspace. + SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 + IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE + ! Check that P* is closer than the current solution. + IF (SIDE2 > MINRAD) CYCLE + ! Update the minimum distance and save the index I. + MINRAD = SIDE2 + SIMPS(2,MI) = I + END DO + IERR(MI) = 0 ! Reset the error flag to 'success' code. + ! Check for extrapolation condition. + IF(SIMPS(2,MI) .EQ. 0) RETURN + ! Add new point to the linear system. + AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) + B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 + RETURN +END IF +! Set the RHS to P^T B. +FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) +! Solve R^T Q^T X = P^T B for Q^T X. +CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) +! Loop through all points P* in PTS. +DO I = 1, N + ! Check that P* is inside the current ball. + IF (DNRM2(D, PTS(:,I) - CENTER(:), 1) > MINRAD) CYCLE ! If not, skip. + ! Check that P* is on the appropriate halfspace. + SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) + IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE ! If not, skip. + ! Perform a rank-1 update to the current QR factorization of A^T by + ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the + ! final column of R. + LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) + CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & + LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 83; RETURN + END IF + ! Update the last element of Q^T X. + WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) + WORK(D) = LQ(D,D) / 2.0_R8 + CENTER(1:D-1) = X(1:D-1) + CENTER(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) + ! Get the center by applying Q to the solution. + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER, D, WORK, LWORK, & + IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 83; RETURN + END IF + ! Update the new radius, center, and simplex. + MINRAD = DNRM2(D, CENTER, 1) + CENTER(:) = CENTER(:) + PTS(:,SIMPS(1,MI)) + SIMPS(D+1,MI) = I +END DO +IERR(MI) = 0 ! Reset the error flag to 'success' code. +! Check for extrapolation condition. +IF(SIMPS(D+1,MI) .EQ. 0) RETURN +! Add new point to the linear system. +AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) +B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 +RETURN +END SUBROUTINE MAKESIMPLEX + +SUBROUTINE MAKEPLANE() +! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed +! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. +! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal +! vector is any nonzero vector in ker A, where the matrix +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. +! +! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR +! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. +! Then the last column of Q is orthogonal to the range of A^T, and in ker A. +! +! Upon output, PLANE(1:D) contains the normal vector c and PLANE(D+1) +! contains \alpha defining the plane. Also, LQ, IPIV, and TAU define a QR +! factorizaton of the first D-1 columns of A^T. + +IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. + ! Compute the QR factorization. + IPIV=0 + LQ = AT + CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 80; RETURN + END IF + ! The nullspace is given by the last column of Q. + PLANE(1:D-1) = 0.0_R8 + PLANE(D) = 1.0_R8 + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & + LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 83; RETURN + END IF + ! Calculate the constant \alpha defining the plane. + PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) +ELSE ! Special case where D=1. + PLANE(1) = 1.0_R8 + PLANE(2) = PTS(1,SIMPS(1,MI)) +END IF +RETURN +END SUBROUTINE MAKEPLANE + +FUNCTION PTINSIMP() RESULT(TF) +! Determine if any interpolation points are in the current simplex, whose +! vertices P_1, P_2, ..., P_{D+1} are indexed by SIMPS(:,MI). These +! vertices determine a positive cone with generators V_I = P_{I+1} - P_1, +! I = 1, ..., D. For each interpolation point Q* in Q, Q* - P_1 can be +! expressed as a unique linear combination of the V_I. If all these linear +! weights are nonnegative and sum to less than or equal to 1.0, then Q* is +! in the simplex with vertices {P_I}_{I=1}^{D+1}. +! +! If any interpolation points in Q are contained in the simplex whose +! vertices are indexed by SIMPS(:,MI), then those points are marked as solved +! and the values of SIMPS and WEIGHTS are updated appropriately. On output, +! WEIGHTS(:,MI) contains the affine weights for producing Q(:,MI) as an +! affine combination of the points in PTS indexed by SIMPS(:,MI). If these +! weights are nonnegative, then PTINSIMP() returns TRUE. + +! Initialize the return value and local variables. +LOGICAL :: TF ! True/False value. +TF = .FALSE. + +! Compute the LU factorization of the matrix A^T, whose columns are +! P_{I+1} - P_1. +LQ = AT +CALL DGETRF(D, D, LQ, D, IPIV, IERR(MI)) +IF (IERR(MI) < 0) THEN ! LAPACK illegal input. + IERR(MI) = 81; RETURN +ELSE IF (IERR(MI) > 0) THEN ! Rank-deficiency detected. + IERR(MI) = 61; RETURN +END IF +! Solve A^T w = WORK to get the affine weights for Q(:,MI) or its projection. +WORK(1:D) = PROJ(:) - PTS(:,SIMPS(1,MI)) +CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(1:D), D, IERR(MI)) +IF (IERR(MI) < 0) THEN ! LAPACK illegal input. + IERR(MI) = 82; RETURN +END IF +WEIGHTS(2:D+1,MI) = WORK(1:D) +WEIGHTS(1,MI) = 1.0_R8 - SUM(WEIGHTS(2:D+1,MI)) +! Check if the weights for Q(:,MI) are nonnegative. +IF (ALL(WEIGHTS(:,MI) .GE. -EPSL)) TF = .TRUE. + +! Compute the affine weights for the rest of the interpolation points. +DO I = MI+1, M + ! Check that no solution has already been found. + IF (IERR(I) .NE. 40) CYCLE + ! Solve A^T w = WORK to get the affine weights for Q(:,I). + WORK(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) + CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(2:D+1), D, ITMP) + IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. + ! Check if the weights define a convex combination. + WORK(1) = 1.0_R8 - SUM(WORK(2:D+1)) + IF (ALL(WORK(1:D+1) .GE. -EPSL)) THEN + ! Copy the simplex indices and weights then flag as complete. + SIMPS(:,I) = SIMPS(:,MI) + WEIGHTS(:,I) = WORK(1:D+1) + IERR(I) = 0 + END IF +END DO +RETURN +END FUNCTION PTINSIMP + +SUBROUTINE PROJECT() +! Project a point outside the convex hull of the point set onto the convex hull +! by solving an inequality constrained least squares problem. The solution to +! the least squares problem gives the projection as a convex combination of the +! data points. The projection can then be computed by performing a matrix +! vector multiplication. + +! Allocate work arrays. +IF (.NOT. ALLOCATED(IWORK_DWNNLS)) THEN + ALLOCATE(IWORK_DWNNLS(D+1+N), STAT=IERR(MI)) + IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF +END IF +IF (.NOT. ALLOCATED(WORK_DWNNLS)) THEN + ALLOCATE(WORK_DWNNLS(D+1+N*5), STAT=IERR(MI)) + IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF +END IF +IF (.NOT. ALLOCATED(W_DWNNLS)) THEN + ALLOCATE(W_DWNNLS(D+1,N+1), STAT=IERR(MI)) + IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF +END IF +IF (.NOT. ALLOCATED(X_DWNNLS)) THEN + ALLOCATE(X_DWNNLS(N), STAT=IERR(MI)) + IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF +END IF + +! Initialize work array and settings values. +PRGOPT_DWNNLS(1) = 1.0_R8 +IWORK_DWNNLS(1) = D+1+5*N +IWORK_DWNNLS(2) = D+1+N +W_DWNNLS(1, :) = 1.0_R8 ! Set convexity (equality) constraint. +W_DWNNLS(2:D+1,1:N) = PTS(:,:) ! Copy data points. +W_DWNNLS(2:D+1,N+1) = PROJ(:) ! Copy extrapolation point. +! Compute the solution to the inequality constrained least squares problem to +! get the projection coefficients. +CALL DWNNLS(W_DWNNLS, D+1, 1, D, N, 0, PRGOPT_DWNNLS, X_DWNNLS, RNORML, & + IERR(MI), IWORK_DWNNLS, WORK_DWNNLS) +IF (IERR(MI) .EQ. 1) THEN ! Failure to converge. + IERR(MI) = 71; RETURN +ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. + IERR(MI) = 72; RETURN +END IF +! Zero all weights that are approximately zero and renormalize the sum. +WHERE (X_DWNNLS < EPSL) X_DWNNLS = 0.0_R8 +X_DWNNLS(:) = X_DWNNLS(:) / SUM(X_DWNNLS) +! Compute the actual projection via matrix vector multiplication. +CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) +RNORML = DNRM2(D, PROJ(:) - Q(:,MI), 1) +RETURN +END SUBROUTINE PROJECT + +SUBROUTINE RESCALE(MINDIST, DIAMETER, SCALE) +! Rescale and transform data to be centered at the origin with unit +! radius. This subroutine has O(n^2) complexity. +! +! On output, PTS and Q have been rescaled and shifted. All the data +! points in PTS are centered with unit radius, and the points in Q +! have been shifted and scaled in relation to PTS. +! +! MINDIST is a real number containing the (scaled) minimum distance +! between any two data points in PTS. +! +! DIAMETER is a real number containing the (scaled) diameter of the +! data set PTS. +! +! SCALE contains the real factor used to transform the data and +! interpolation points: scaled value = (original value - +! barycenter of data points)/SCALE. + +! Output arguments. +REAL(KIND=R8), INTENT(OUT) :: MINDIST, DIAMETER, SCALE + +! Local variables. +REAL(KIND=R8) :: PTS_CENTER(D) ! The center of the data points PTS. +REAL(KIND=R8) :: DISTANCE ! The current distance. + +! Initialize local values. +MINDIST = HUGE(0.0_R8) +DIAMETER = 0.0_R8 +SCALE = 0.0_R8 + +! Compute barycenter of all data points. +PTS_CENTER(:) = SUM(PTS(:,:), DIM=2)/REAL(N, KIND=R8) +! Center the points. +FORALL (I = 1:N) PTS(:,I) = PTS(:,I) - PTS_CENTER(:) +! Compute the scale factor (for unit radius). +DO I = 1, N ! Cycle through all points again. + DISTANCE = DNRM2(D, PTS(:,I), 1) ! Compute the distance from the center. + IF (DISTANCE > SCALE) THEN ! Compare to the current radius. + SCALE = DISTANCE + END IF +END DO +! Scale the points to unit radius. +PTS = PTS / SCALE +! Also transform Q similarly. +FORALL (I = 1:M) Q(:,I) = (Q(:,I) - PTS_CENTER(:)) / SCALE +! Compute the minimum and maximum distances. +IF (EXACTL) THEN + ! If exact error error checking is turned on, then compute the DIAMETER + ! and MINDIST values. + DO I = 1, N ! Cycle through all pairs of points. + DO J = I + 1, N + DISTANCE = DNRM2(D, PTS(:,I) - PTS(:,J), 1) ! Compute the distance. + IF (DISTANCE > DIAMETER) THEN ! Compare to the current diameter. + DIAMETER = DISTANCE + END IF + IF (DISTANCE < MINDIST) THEN ! Compare to the current minimum distance. + MINDIST = DISTANCE + END IF + END DO + END DO +ELSE + ! If exact error checking is turned off, then the diameter is approximately + ! 2.0 after rescaling and centering the points. The MINDIST is not computed. + DIAMETER = 2.0_R8 + MINDIST = 1.0_R8 +END IF +RETURN +END SUBROUTINE RESCALE + +END SUBROUTINE DELAUNAYSPARSES + + +SUBROUTINE DELAUNAYSPARSEP( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EXACT, & + PMODE ) +! This is a parallel implementation of an algorithm for efficiently performing +! interpolation in R^D via the Delaunay triangulation. The algorithm is fully +! described and analyzed in +! +! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. +! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate +! interpolation in arbitrary dimension via the Delaunay triangulation. In +! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, +! USA. Article 12, 8 pages. +! +! +! On input: +! +! D is the dimension of the space for PTS and Q. +! +! N is the number of data points in PTS. +! +! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the +! coordinates of a single data point in R^D. +! +! M is the number of interpolation points in Q. +! +! Q(1:D,1:M) is a real valued matrix with M columns, each containing the +! coordinates of a single interpolation point in R^D. +! +! +! On output: +! +! PTS and Q have been rescaled and shifted. All the data points in PTS +! are now contained in the unit hyperball in R^D, and the points in Q +! have been shifted and scaled accordingly in relation to PTS. +! +! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns +! in PTS) for the D+1 vertices of the Delaunay simplex containing each +! interpolation point in Q. +! +! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each +! point in Q as a convex combination of the D+1 corresponding vertices +! in SIMPS. +! +! IERR(1:M) contains integer valued error flags associated with the +! computation of each of the M interpolation points in Q. The error +! codes are: +! +! 00 : Succesful interpolation. +! 01 : Succesful extrapolation (up to the allowed extrapolation distance). +! 02 : This point was outside the allowed extrapolation distance; the +! corresponding entries in SIMPS and WEIGHTS contain zero values. +! +! 10 : The dimension D must be positive. +! 11 : Too few data points to construct a triangulation (i.e., N < D+1). +! 12 : No interpolation points given (i.e., M < 1). +! 13 : The first dimension of PTS does not agree with the dimension D. +! 14 : The second dimension of PTS does not agree with the number of points N. +! 15 : The first dimension of Q does not agree with the dimension D. +! 16 : The second dimension of Q does not agree with the number of +! interpolation points M. +! 17 : The first dimension of the output array SIMPS does not match the number +! of vertices needed for a D-simplex (D+1). +! 18 : The second dimension of the output array SIMPS does not match the +! number of interpolation points M. +! 19 : The first dimension of the output array WEIGHTS does not match the +! number of vertices for a a D-simplex (D+1). +! 20 : The second dimension of the output array WEIGHTS does not match the +! number of interpolation points M. +! 21 : The size of the error array IERR does not match the number of +! interpolation points M. +! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. +! 23 : The first dimension of INTERP_IN does not match the first +! dimension of INTERP_OUT. +! 24 : The second dimension of INTERP_IN does not match the number of +! data points PTS. +! 25 : The second dimension of INTERP_OUT does not match the number of +! interpolation points M. +! 26 : The budget supplied in IBUDGET does not contain a positive +! integer. +! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. +! 28 : The size of the RNORM output array does not match the number of +! interpolation points M. +! +! 30 : Two or more points in the data set PTS are too close together with +! respect to the working precision (EPS), which would result in a +! numerically degenerate simplex. +! 31 : All the data points in PTS lie in some lower dimensional linear +! manifold (up to the working precision), and no valid triangulation +! exists. +! 40 : An error caused DELAUNAYSPARSEP to terminate before this value could +! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may +! contain garbage values. +! +! 50 : A memory allocation error occurred while allocating the work array +! WORK. +! +! 60 : The budget was exceeded before the algorithm converged on this +! value. If the dimension is high, try increasing IBUDGET. This +! error can also be caused by a working precision EPS that is too +! small for the conditioning of the problem. +! +! 61 : A value that was judged appropriate later caused LAPACK to encounter a +! singularity. Try increasing the value of EPS. +! +! 70 : Allocation error for the extrapolation work arrays. +! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection +! of an extrapolation point onto the convex hull. +! 72 : The SLATEC subroutine DWNNLS has reported a usage error. +! +! The errors 72, 80--83 should never occur, and likely indicate a +! compiler bug or hardware failure. +! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. +! 81 : The LAPACK subroutine DGETRF has reported an illegal value. +! 82 : The LAPACK subroutine DGETRS has reported an illegal value. +! 83 : The LAPACK subroutine DORMQR has reported an illegal value. +! +! 90 : The value of PMODE is not valid. +! +! +! Optional arguments: +! +! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of +! the data points in PTS on input. The first dimension of INTERP_IN is +! inferred to be the dimension of these response vectors, and the +! second dimension must match N. If present, the response values will +! be computed for each interpolation point in Q, and stored in INTERP_OUT, +! which therefore must also be present. If both INTERP_IN and INTERP_OUT +! are omitted, only the containing simplices and convex combination +! weights are returned. +! +! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each +! interpolation point in Q on output. The first dimension of INTERP_OU +! must match the first dimension of INTERP_IN, and the second dimension +! must match M. If present, the response values at each interpolation +! point are computed as a convex combination of the response values +! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing +! that interpolation point. Therefore, if INTERP_OUT is present, then +! INTERP_IN must also be present. If both are omitted, only the +! simplices and convex combination weights are returned. +! +! EPS contains the real working precision for the problem on input. By +! default, EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff +! for the machine. In general, any values that differ by less than EPS +! are judged as equal, and any weights that are greater than -EPS are +! judged as nonnegative. EPS cannot take a value less than the default +! value of \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, +! the default value will be used instead automatically. +! +! EXTRAP contains the real maximum extrapolation distance (relative to the +! diameter of PTS) on input. Interpolation at a point outside the convex +! hull of PTS is done by projecting that point onto the convex hull, and +! then doing normal Delaunay interpolation at that projection. +! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) +! units outside the convex hull of PTS will not be done and an error code +! of 2 will be returned. Note that computing the projection can be +! expensive. Setting EXTRAP=0 will cause all extrapolation points to be +! ignored without ever computing a projection. By default, EXTRAP=0.1 +! (extrapolate by up to 10% of the diameter of PTS). +! +! RNORM(1:M) contains the real unscaled projection (2-norm) distances from +! any projection computations on output. If not present, these distances +! are still computed for each extrapolation point, but are never returned. +! +! IBUDGET on input contains the integer budget for performing flips while +! iterating toward the simplex containing each interpolation point in Q. +! This prevents DELAUNAYSPARSEP from falling into an infinite loop when +! an inappropriate value of EPS is given with respect to the problem +! conditioning. By default, IBUDGET=50000. However, for extremely +! high-dimensional problems and pathological inputs, the default value +! may be insufficient. +! +! CHAIN is a logical input argument that determines whether a new first +! simplex should be constructed for each interpolation point +! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." +! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not +! recommended, unless the size of the triangulation is relatively small +! or the interpolation points are known to be tightly clustered. +! +! EXACT is a logical input argument that determines whether the exact +! diameter should be computed and whether a check for duplicate data +! points should be performed in advance. When EXACT=.FALSE., the +! diameter of PTS is approximated by twice the distance from the +! barycenter of PTS to the farthest point in PTS, and no check is +! done to find the closest pair of points, which could result in hard +! to find bugs later on. When EXACT=.TRUE., the exact diameter is +! computed and an error is returned whenever PTS contains duplicate +! values up to the precision EPS. By default EXACT=.TRUE., but setting +! EXACT=.FALSE. could result in significant speedup when N is large. +! It is strongly recommended that most users leave EXACT=.TRUE., as +! setting EXACT=.FALSE. could result in input errors that are difficult +! to identify. Also, the diameter approximation could be wrong by up to +! a factor of two. +! +! PMODE is an integer specifying the level of parallelism to be exploited. +! If PMODE = 1, then parallelism is exploited at the level of the loop +! over all interpolation points (Level 1 parallelism). +! If PMODE = 2, then parallelism is exploited at the level of the loops +! over data points when constructing/flipping simplices (Level 2 +! parallelism). +! If PMODE = 3, then parallelism is exploited at both levels. Note: this +! implies that the total number of threads active at any time could be up +! to OMP_NUM_THREADS^2. +! By default, PMODE is set to 1 if there is more than 1 interpolation +! point and 2 otherwise. +! +! +! Subroutines and functions directly referenced from BLAS are +! DDOT, DGEMV, DNRM2, DTRSM, +! and from LAPACK are +! DGEQP3, DGETRF, DGETRS, DORMQR. +! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its +! SLATEC dependencies have been slightly edited to comply with the Fortran +! 2008 standard, with all print statements and references to stderr being +! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 +! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS +! Algorithm 777) is used for the real data type. The REAL_PRECISION module, +! DELAUNAYSPARSEP, and DWNNLS and its dependencies comply with the Fortran +! 2008 standard. +! +! Primary Author: Tyler H. Chang +! Last Update: March, 2020 +! +USE REAL_PRECISION, ONLY : R8 +IMPLICIT NONE + +! Input arguments. +INTEGER, INTENT(IN) :: D, N +REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) ! Rescaled on output. +INTEGER, INTENT(IN) :: M +REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) ! Rescaled on output. +! Output arguments. +INTEGER, INTENT(OUT) :: SIMPS(:,:) +REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) +INTEGER, INTENT(OUT) :: IERR(:) +! Optional arguments. +REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) +REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) +REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP +REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) +INTEGER, INTENT(IN), OPTIONAL :: IBUDGET, PMODE +LOGICAL, INTENT(IN), OPTIONAL :: CHAIN +LOGICAL, INTENT(IN), OPTIONAL :: EXACT + +! Local copies of optional input arguments. +REAL(KIND=R8) :: EPSL, EXTRAPL +INTEGER :: IBUDGETL +LOGICAL :: CHAINL, EXACTL, PLVL1, PLVL2 + +! Local variables. +LOGICAL :: PTINSIMP ! Tells if Q(:,MI) is in SIMPS(:,MI). +INTEGER :: I, J, K ! Loop iteration variables. +INTEGER :: IEXTRAPS ! Extrapolation budget. +INTEGER :: IERR_PRIV ! Private copy of the error flag. +INTEGER :: ITMP, JTMP ! Temporary variables for swapping, looping, etc. +INTEGER :: LWORK ! Size of the work array. +INTEGER :: MI ! Index of current interpolation point. +INTEGER :: VERTEX_PRIV ! Private copy of next vertex to add. +REAL(KIND=R8) :: CURRRAD ! Radius of the current circumsphere. +REAL(KIND=R8) :: MINRAD ! Minimum circumsphere radius observed. +REAL(KIND=R8) :: MINRAD_PRIV ! Private copy of MINRAD. +REAL(KIND=R8) :: PTS_DIAM ! Scaled diameter of data set. +REAL(KIND=R8) :: PTS_SCALE ! Data scaling factor. +REAL(KIND=R8) :: RNORML ! Euclidean norm of the projection residual. +REAL(KIND=R8) :: SIDE1, SIDE2 ! Signs (+/-1) denoting sides of a facet. + +! Local arrays, requiring O(d^2) additional memory. +INTEGER :: IPIV(D) ! Pivot indices. +INTEGER :: SEED(D+1) ! Copy of the SEED simplex. Only used if CHAIN = .TRUE. +REAL(KIND=R8) :: AT(D,D) ! The transpose of A, the linear coefficient matrix. +REAL(KIND=R8) :: B(D) ! The RHS of a linear system. +REAL(KIND=R8) :: CENTER(D) ! The circumcenter of a simplex. +REAL(KIND=R8) :: CENTER_PRIV(D) ! Private copy of CENTER. +REAL(KIND=R8) :: LQ(D,D) ! Holds LU or QR factorization of AT. +REAL(KIND=R8) :: PLANE(D+1) ! The hyperplane containing a facet. +REAL(KIND=R8) :: PRGOPT_DWNNLS(1) ! Options array for DWNNLS. +REAL(KIND=R8) :: PROJ(D) ! The projection of the current iterate. +REAL(KIND=R8) :: TAU(D) ! Householder reflector constants. +REAL(KIND=R8) :: X(D) ! The solution to a linear system. + +! Extrapolation work arrays are only allocated if DWNNLS is called. +INTEGER, ALLOCATABLE :: IWORK_DWNNLS(:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: W_DWNNLS(:,:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: WORK(:) ! Allocated with size LWORK. +REAL(KIND=R8), ALLOCATABLE :: WORK_DWNNLS(:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: X_DWNNLS(:) ! Only for DWNNLS. + +! External functions and subroutines. +REAL(KIND=R8), EXTERNAL :: DDOT ! Inner product (BLAS). +REAL(KIND=R8), EXTERNAL :: DNRM2 ! Euclidean norm (BLAS). +EXTERNAL :: DGEMV ! General matrix vector multiply (BLAS) +EXTERNAL :: DGEQP3 ! Perform a QR factorization with column pivoting (LAPACK). +EXTERNAL :: DGETRF ! Perform a LU factorization with partial pivoting (LAPACK). +EXTERNAL :: DGETRS ! Use the output of DGETRF to solve a linear system (LAPACK). +EXTERNAL :: DORMQR ! Apply householder reflectors to a matrix (LAPACK). +EXTERNAL :: DTRSM ! Perform a triangular solve (BLAS). +EXTERNAL :: DWNNLS ! Solve an inequality constrained least squares problem + ! (SLATEC). + +! Check for input size and dimension errors. +IF (D < 1) THEN ! The dimension must satisfy D > 0. + IERR(:) = 10; RETURN; END IF +IF (N < D+1) THEN ! Must have at least D+1 data points. + IERR(:) = 11; RETURN; END IF +IF (M < 1) THEN ! Must have at least one interpolation point. + IERR(:) = 12; RETURN; END IF +IF (SIZE(PTS,1) .NE. D) THEN ! Dimension of PTS array should match. + IERR(:) = 13; RETURN; END IF +IF (SIZE(PTS,2) .NE. N) THEN ! Number of data points should match. + IERR(:) = 14; RETURN; END IF +IF (SIZE(Q,1) .NE. D) THEN ! Dimension of Q should match. + IERR(:) = 15; RETURN; END IF +IF (SIZE(Q,2) .NE. M) THEN ! Number of interpolation points should match. + IERR(:) = 16; RETURN; END IF +IF (SIZE(SIMPS,1) .NE. D+1) THEN ! Need space for D+1 vertices per simplex. + IERR(:) = 17; RETURN; END IF +IF (SIZE(SIMPS,2) .NE. M) THEN ! There will be M output simplices. + IERR(:) = 18; RETURN; END IF +IF (SIZE(WEIGHTS,1) .NE. D+1) THEN ! There will be D+1 weights per simplex. + IERR(:) = 19; RETURN; END IF +IF (SIZE(WEIGHTS,2) .NE. M) THEN ! One vector of weights per simplex. + IERR(:) = 20; RETURN; END IF +IF (SIZE(IERR) .NE. M) THEN ! An error flag for each interpolation point. + IERR(:) = 21; RETURN; END IF + +! Check for optional arguments. +IF (PRESENT(INTERP_IN) .NEQV. PRESENT(INTERP_OUT)) THEN + IERR(:) = 22; RETURN; END IF +IF (PRESENT(INTERP_IN)) THEN ! Sizes must agree. + IF (SIZE(INTERP_IN,1) .NE. SIZE(INTERP_OUT,1)) THEN + IERR(:) = 23 ; RETURN; END IF + IF(SIZE(INTERP_IN,2) .NE. N) THEN + IERR(:) = 24; RETURN; END IF + IF (SIZE(INTERP_OUT,2) .NE. M) THEN + IERR(:) = 25; RETURN; END IF + INTERP_OUT(:,:) = 0.0_R8 ! Initialize output to zeros. +END IF +EPSL = SQRT(EPSILON(0.0_R8)) ! Get the machine unit roundoff constant. +IF (PRESENT(EPS)) THEN + IF (EPSL < EPS) THEN ! If the given precision is too small, ignore it. + EPSL = EPS + END IF +END IF +IF (PRESENT(IBUDGET)) THEN + IBUDGETL = IBUDGET ! Use the given budget if present. + IF (IBUDGETL < 1) THEN + IERR(:) = 26; RETURN; END IF +ELSE + IBUDGETL = 50000 ! Default value for budget. +END IF +IF (PRESENT(EXTRAP)) THEN + EXTRAPL = EXTRAP + IF (EXTRAPL < 0) THEN ! Check that the extrapolation distance is legal. + IERR(:) = 27; RETURN; END IF +ELSE + EXTRAPL = 0.1_R8 ! Default extrapolation distance (for normalized points). +END IF +IF (PRESENT(RNORM)) THEN + IF (SIZE(RNORM,1) .NE. M) THEN ! The length of the array must match. + IERR(:) = 28; RETURN; END IF + RNORM(:) = 0.0_R8 ! Initialize output to zeros. +END IF +IF (PRESENT(CHAIN)) THEN + CHAINL = CHAIN ! Turn chaining on, if necessarry. + SEED(:) = 0 ! Initialize SEED in case it is needed. +ELSE + CHAINL = .FALSE. +END IF +IF (PRESENT(EXACT)) THEN + EXACTL = EXACT ! Set error checking and exact diameter computations. +ELSE + EXACTL = .TRUE. +END IF +! Set the PMODE. +PLVL1 = .FALSE. +PLVL2 = .FALSE. +IF (PRESENT(PMODE)) THEN ! Check PMODE for legal values. + IF (PMODE .EQ. 1) THEN + PLVL1 = .TRUE. + ELSE IF (PMODE .EQ. 2) THEN + PLVL2 = .TRUE. + ELSE IF (PMODE .EQ. 3) THEN + PLVL1 = .TRUE.; PLVL2 = .TRUE. + ELSE + IERR(:) = 90; RETURN + END IF +ELSE ! The default setting for PMODE is level 1 parallelism if M > 1. + IF (M > 1) THEN + PLVL1 = .TRUE. + ELSE + PLVL2 = .TRUE. + END IF +END IF + +! Scale and center the data points and interpolation points. +CALL RESCALE(MINRAD, PTS_DIAM, PTS_SCALE) +IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. + IERR(:) = 30; RETURN; END IF + +! Query DGEQP3 for optimal work array size (LWORK). +LWORK = -1 +CALL DGEQP3(D,D,LQ,D,IPIV,TAU,B,LWORK,IERR(1)) +LWORK = INT(B(1)) ! Compute the optimal work array size. +ALLOCATE(WORK(LWORK), STAT=I) ! Allocate WORK to size LWORK. +IF (I .NE. 0) THEN ! Check for memory allocation errors. + IERR(:) = 50; RETURN; END IF + +! Initialize PRGOPT_DWNNLS in case of extrapolation. +PRGOPT_DWNNLS(1) = 1.0_R8 + +! Initialize all error codes to "TBD" values. +IERR(:) = 40 + +! Begin level 1 parallel region (over all interpolation points in Q). +!$OMP PARALLEL & +! +! The FIRSTPRIVATE list specifies initialized variables, of which each +! thread has a private copy. +!$OMP& FIRSTPRIVATE(SEED), & +! +! The PRIVATE list specifies uninitialized variables, of which each +! thread has a private copy. +!$OMP& PRIVATE(I, J, K, IEXTRAPS, ITMP, JTMP, CURRRAD, MI, MINRAD, & +!$OMP& RNORML, SIDE1, SIDE2, IERR_PRIV, VERTEX_PRIV, MINRAD_PRIV, & +!$OMP& PTINSIMP, IPIV, AT, B, CENTER, CENTER_PRIV, LQ, PLANE, & +!$OMP& PROJ, TAU, WORK, X, IWORK_DWNNLS, W_DWNNLS, WORK_DWNNLS, & +!$OMP& X_DWNNLS), & +! +! Any variables not explicitly listed above receive the SHARED scope +! by default and are visible across all threads. +!$OMP& DEFAULT(SHARED), & +! +!$OMP& IF(PLVL1) +!$OMP DO SCHEDULE(DYNAMIC) +OUTER : DO MI = 1, M + !$OMP CRITICAL(CHECK_IERR) + ! Check if this interpolation point was already found. + IF (IERR(MI) .EQ. 40) THEN + IERR(MI) = 0 + IERR_PRIV = 0 + ELSE + IERR_PRIV = -1 + END IF + !$OMP END CRITICAL(CHECK_IERR) + IF(IERR_PRIV .EQ. -1) CYCLE OUTER + + ! Initialize the projection and reset the residual. + PROJ(:) = Q(:,MI) + RNORML = 0.0_R8 + + ! Check if extrapolation is enabled. + IF (EXTRAPL < EPSL) THEN + IEXTRAPS = -1 ! If not, set the extrapolation budget negative. + ELSE + IEXTRAPS = 1 ! Allow for exactly one projection for this point. + END IF + + ! If there is no useable seed or if chaining is turned off, then make a new + ! simplex. + IF( (.NOT. CHAINL) .OR. SEED(1) .EQ. 0) THEN +! CALL MAKEFIRSTSIMP(); IF(IERR_PRIV .NE. 0) CYCLE OUTER + + +!****************************************************************************** +! Due to OpenMP's handling of variable scope, the parallel implementation of +! the subroutine MAKEFIRSTSIMP() has been in-lined here. +! +! SUBROUTINE MAKEFIRSTSIMP() +! +! Iteratively construct the first simplex by choosing points that +! minimize the radius of the smallest circumball. Let P_1, P_2, ..., P_K +! denote the current list of vertices for the simplex. Let P* denote the +! candidate vertex to be added to the simplex. Let CENTER denote the +! circumcenter of the simplex. Then +! +! X = CENTER - P_1 +! +! is given by the minimum norm solution to the underdetermined linear system +! +! A X = B, where +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_K - P_1, P* - P_1 ] and +! B = [ /2, /2, ..., /2 ]^T. +! +! Then the radius of the smallest circumsphere is CURRRAD = \| X \|, +! and the next vertex is given by P_{K+1} = argmin_{P*} CURRRAD, where P* +! ranges over points in PTS that are not already a vertex of the simplex. +! +! On output, this subroutine fully populates the matrix A^T and vector B, +! and fills SIMPS(:,MI) with the indices of a valid Delaunay simplex. + +! Initialize simplex and shared variables. +SIMPS(:,MI) = 0 +MINRAD_PRIV = HUGE(0.0_R8) +MINRAD = HUGE(0.0_R8) + +! Below is a Level 2 parallel region over N points in PTS to find the +! first and second vertices SIMPS(1,MI) and SIMPS(2,MI). +!$OMP PARALLEL & +! +! The FIRSTPRIVATE list specifies initialized variables, of which each +! thread has a private copy. +!$OMP& FIRSTPRIVATE(MINRAD_PRIV), & +! +! The PRIVATE list specifies uninitialized variables, of which each +! thread has a private copy. +!$OMP& PRIVATE(I, CURRRAD, VERTEX_PRIV), & +! +! Any variables not explicitly listed above receive the SHARED scope +! by default and are visible across all threads. +!$OMP& DEFAULT(SHARED), & +! +!$OMP& IF(PLVL2) +! Find the first point, i.e., the closest point to Q(:,MI). +!$OMP DO SCHEDULE(STATIC) +DO I = 1, N + ! Check the distance to Q(:,MI) + CURRRAD = DNRM2(D, PTS(:,I) - PROJ(:), 1) + IF (CURRRAD < MINRAD_PRIV) THEN + MINRAD_PRIV = CURRRAD; VERTEX_PRIV = I; + END IF +END DO +!$OMP END DO +!$OMP CRITICAL(REDUC_1) +IF (MINRAD_PRIV < MINRAD) THEN + MINRAD = MINRAD_PRIV; SIMPS(1,MI) = VERTEX_PRIV; +END IF +!$OMP END CRITICAL(REDUC_1) +! Find the second point, i.e., the closest point to PTS(:,SIMPS(1,MI)). +MINRAD_PRIV = HUGE(0.0_R8) +!$OMP BARRIER +!$OMP SINGLE +MINRAD = HUGE(0.0_R8) +!$OMP END SINGLE +!$OMP DO SCHEDULE(STATIC) +DO I = 1, N + ! Skip repeated vertices. + IF (I .EQ. SIMPS(1,MI)) CYCLE + ! Check the diameter of the resulting circumsphere. + CURRRAD = DNRM2(D, PTS(:,I)-PTS(:,SIMPS(1,MI)), 1) + IF (CURRRAD < MINRAD_PRIV) THEN + MINRAD_PRIV = CURRRAD; VERTEX_PRIV = I + END IF +END DO +!$OMP END DO +!$OMP CRITICAL(REDUC_2) +IF (MINRAD_PRIV < MINRAD) THEN + MINRAD = MINRAD_PRIV; SIMPS(2,MI) = VERTEX_PRIV +END IF +!$OMP END CRITICAL(REDUC_2) +!$OMP END PARALLEL +! This is the end of the Level 2 parallel block. +IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. + IERR(MI) = 30; CYCLE OUTER; END IF + +! Set up the first row of the system A X = B. +AT(:,1) = PTS(:,SIMPS(2,MI)) - PTS(:,SIMPS(1,MI)) +B(1) = DDOT(D, AT(:,1), 1, AT(:,1), 1) / 2.0_R8 + +! Loop to collect the remaining D-1 vertices for the first simplex. +DO I = 2, D + ! Compute A^T P = Q R for the current matrix A^T. + LQ(:,1:I-1) = AT(:,1:I-1) + CALL DGEQP3(D, I-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 80 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Set the RHS to P^T B. + FORALL (ITMP = 1:I-1) X(ITMP) = B(IPIV(ITMP)) + ! Solve R^T Q^T X = P^T B for Q^T X, and save for later. + CALL DTRSM('L', 'U', 'T', 'N', I-1, 1, 1.0_R8, LQ, D, X, D) + ! Make a copy for computing the current center. + CENTER(1:I-1) = X(1:I-1) + CENTER(I:D) = 0.0_R8 + ! Apply Q from the left. + CALL DORMQR('L', 'N', D, 1, I-1, LQ, D, TAU, CENTER, D, WORK, & + LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 83 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + CENTER = CENTER + PTS(:,SIMPS(1,MI)) + ! Re-initialize the radius for each iteration. + MINRAD = HUGE(0.0_R8) + MINRAD_PRIV = HUGE(0.0_R8) + VERTEX_PRIV = 0 + + ! This is another Level 2 parallel block over N points in PTS. + !$OMP PARALLEL & + ! + ! The FIRSTPRIVATE list specifies initialized variables, of which each + ! thread has a private copy. + !$OMP& FIRSTPRIVATE(LQ, MINRAD_PRIV, VERTEX_PRIV, X), & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(J, CURRRAD, WORK), & + ! + ! The REDUCTION clause specifies a PRIVATE variable that will retain + ! some value (i.e., max, min, sum, etc.) upon output. + !$OMP& REDUCTION(MAX:IERR_PRIV), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& IF(PLVL2) + + ! Initialize the error flag. + IERR_PRIV = 0 + !$OMP DO SCHEDULE(STATIC) + DO J = 1, N + IF (IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. + ! Check that this point is not already in the simplex. + IF (ANY(SIMPS(:,MI) .EQ. J)) CYCLE + ! If PTS(:,J) is more than twice MINRAD_PRIV from CENTER, do a quick skip. + IF (DNRM2(D, CENTER - PTS(:,J), 1) > 2.0_R8 * MINRAD_PRIV) CYCLE + ! Perform a rank-1 update to the current QR factorization of A^T by + ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the + ! final column of R. + LQ(:,I) = PTS(:,J) - PTS(:,SIMPS(1,MI)) + CALL DORMQR('L', 'T', D, 1, I-1, LQ(:,1:I-1), D, TAU, LQ(:,I), D, & + WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + IERR_PRIV = 83; CYCLE + END IF + ! Implicitly apply the next Householder reflector. + LQ(I,I) = DNRM2(D+1-I, LQ(I:D,I), 1) + IF (LQ(I,I) < EPSL) THEN ! A is rank-deficient. + CYCLE ! If rank-deficient, skip this point. + END IF + ! Update the current radius by \| Q^T X \| = \| X \|. + WORK(1:I-1) = (LQ(1:I-1,I) / 2.0_R8) - X(1:I-1) + WORK(I) = LQ(I,I) / 2.0_R8 + X(I) = DDOT(I, LQ(1:I,I), 1, WORK(1:I), 1) / LQ(I,I) + CURRRAD = DNRM2(I, X(1:I), 1) + ! Compare the last component of Q^T X to the current minimum. + IF (CURRRAD < MINRAD_PRIV) THEN + MINRAD_PRIV = CURRRAD; VERTEX_PRIV = J + END IF + END DO + !$OMP END DO + !$OMP CRITICAL(REDUC_3) + IF (MINRAD_PRIV < MINRAD) THEN + MINRAD = MINRAD_PRIV; SIMPS(I+1,MI) = VERTEX_PRIV + END IF + !$OMP END CRITICAL(REDUC_3) + !$OMP END PARALLEL + ! End of Level 2 parallel block. + + ! Check the final error flag. + IF (IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = IERR_PRIV + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Check that a point was found. If not, then all the points must lie in a + ! lower dimensional linear manifold (error case). + IF (SIMPS(I+1,MI) .EQ. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 31 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! If all operations were successful, add the best P* to the linear system. + AT(:,I) = PTS(:,SIMPS(I+1,MI)) - PTS(:,SIMPS(1,MI)) + B(I) = DDOT(D, AT(:,I), 1, AT(:,I), 1) / 2.0_R8 +END DO +! RETURN +! END SUBROUTINE MAKEFIRSTSIMP +! This marks the end of the in-lined MAKEFIRSTSIMP() subroutine call. +!****************************************************************************** + + + ! Otherwise, use the seed. + ELSE + ! Copy the seed to the current simplex. + SIMPS(:,MI) = SEED(:) + ! Rebuild the linear system. + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + + ! Inner loop searching for a simplex containing the point Q(:,MI). + INNER : DO K = 1, IBUDGETL + + ! If chaining is on, save each good simplex as the next seed. + IF (CHAINL) SEED(:) = SIMPS(:,MI) + + +!****************************************************************************** +! Due to OpenMP's handling of variable scope, the parallel implementation of +! the subroutine PTINSIMP() has been in-lined here. +! +! FUNCTION PTINSIMP() RESULT(TF) +! Determine if any interpolation points are in the current simplex, whose +! vertices (P_1, P_2, ..., P_{D+1}) are indexed by SIMPS(:,MI). These +! vertices determine a positive cone with generators V_I = P_{I+1} - P_1, +! I = 1, ..., D. For each interpolation point Q* in Q, Q* - P_1 can be +! expressed as a unique linear combination of the V_I. If all these linear +! weights are nonnegative and sum to less than or equal to 1.0, then Q* is +! in the simplex with vertices {P_I}_{I=1}^{D+1}. +! +! If any interpolation points in Q are contained in the simplex whose +! vertices are indexed by SIMPS(:,MI), then those points are marked as solved +! and the values of SIMPS and WEIGHTS are updated appropriately. On output, +! WEIGHTS(:,MI) contains the affine weights for producing Q(:,MI) as an +! affine combination of the points in PTS indexed by SIMPS(:,MI). If these +! weights are nonnegative, then PTINSIMP() returns TRUE. + +! Initialize the return value and local variables. +PTINSIMP = .FALSE. + +! Compute the LU factorization of the matrix A^T, whose columns are +! P_{I+1} - P_1. +LQ = AT +CALL DGETRF(D, D, LQ, D, IPIV, IERR_PRIV) +IF (IERR_PRIV < 0) THEN ! LAPACK illegal input. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 81 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER +ELSE IF (IERR_PRIV > 0) THEN ! Rank-deficiency detected. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 61 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER +END IF +! Solve A^T w = WORK to get the affine weights for Q(:,MI) or its projection. +WORK(1:D) = PROJ(:) - PTS(:,SIMPS(1,MI)) +CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(1:D), D, IERR_PRIV) +IF (IERR_PRIV < 0) THEN ! LAPACK illegal input. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 82 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER +END IF +WEIGHTS(2:D+1,MI) = WORK(1:D) +WEIGHTS(1,MI) = 1.0_R8 - SUM(WEIGHTS(2:D+1,MI)) +! Check if the weights for Q(:,MI) are nonnegative. +IF (ALL(WEIGHTS(:,MI) .GE. -EPSL)) PTINSIMP = .TRUE. + +! If Level 1 parallelism is active, do not parallelize this loop. +IF (PLVL1) THEN + ! Loop over all remaining unsolved interoplation points. Uses PLANE(:) + ! as a work array. + DO I = MI+1, M + ! Check that no solution has already been found. + !$OMP CRITICAL(CHECK_IERR) + ITMP = IERR(I) + !$OMP END CRITICAL(CHECK_IERR) + IF (ITMP .NE. 40) CYCLE + ! Solve A^T w = PLANE to get the affine weights for Q(:,I). + PLANE(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) + CALL DGETRS('N', D, 1, LQ, D, IPIV, PLANE(2:D+1), D, ITMP) + IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. + ! Check if the weights define a convex combination. + PLANE(1) = 1.0_R8 - SUM(PLANE(2:D+1)) + IF (ALL(PLANE(1:D+1) .GE. -EPSL)) THEN + !$OMP CRITICAL(CHECK_IERR) + IF(IERR(I) .EQ. 40) THEN + ! Copy the simplex indices and weights then flag as complete. + SIMPS(:,I) = SIMPS(:,MI) + WEIGHTS(:,I) = PLANE(1:D+1) + IERR(I) = 0 + END IF + !$OMP END CRITICAL(CHECK_IERR) + END IF + END DO +! If Level 1 parallelism is not active, there will be no conflicts for +! parallelizing this loop. +ELSE + ! Level 2 parallel block over all remaining unsolved interoplation + ! points. Uses PLANE(:) as a work array. + !$OMP PARALLEL DO & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(I, PLANE, ITMP), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& SCHEDULE(STATIC), & + !$OMP& IF(PLVL2) + DO I = MI+1, M + ! Check that no solution has already been found. + IF (IERR(I) .NE. 40) CYCLE + ! Solve A^T w = PLANE to get the affine weights for Q(:,I). + PLANE(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) + CALL DGETRS('N', D, 1, LQ, D, IPIV, PLANE(2:D+1), D, ITMP) + IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. + ! Check if the weights define a convex combination. + PLANE(1) = 1.0_R8 - SUM(PLANE(2:D+1)) + IF (ALL(PLANE(1:D+1) .GE. -EPSL)) THEN + ! Copy the simplex indices and weights then flag as complete. + SIMPS(:,I) = SIMPS(:,MI) + WEIGHTS(:,I) = PLANE(1:D+1) + IERR(I) = 0 + END IF + END DO + !$OMP END PARALLEL DO +END IF +! End of Level 2 parallel block. +! RETURN +! END FUNCTION PTINSIMP +! This marks the end of the in-lined PTINSIMP() subroutine call. +!****************************************************************************** + + + ! Check if the current simplex contains Q(:,MI). + IF (PTINSIMP) EXIT INNER + + ! Swap out the least weighted vertex, but save its value in case it + ! needs to be restored later. + JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) + ITMP = SIMPS(JTMP,MI) + SIMPS(JTMP,MI) = SIMPS(D+1,MI) + + ! If the least weighted vertex (index JTMP) is not the first vertex, + ! then just drop row (JTMP-1) from the linear system (corresponding + ! to column (JTMP-1) of A^T). + IF(JTMP .NE. 1) THEN + AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) + ! However, if JTMP = 1, then both A^T and B must be reconstructed. + ELSE + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + + ! Compute the next simplex (do one flip). +! CALL MAKESIMPLEX(); IF (IERR_PRIV .NE. 0) CYCLE OUTER + + +!****************************************************************************** +! Due to OpenMP's handling of variable scope, the parallel implementation of +! the subroutine MAKESIMPLEX() has been in-lined here. +! +! SUBROUTINE MAKESIMPLEX() +! Given a Delaunay facet F whose containing hyperplane does not contain +! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' +! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F +! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the +! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly +! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing +! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices +! P_1, P_2, ..., P_D, P*. Then +! +! X = CENTER - P_1 +! +! is given by the solution to the nonsingular linear system +! +! A X = B where +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and +! B = [ /2, /2, ..., /2 ]^T. +! +! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the +! candidate P* that satisfies both of the following: +! +! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) +! must be on the same side of PLANE. +! +! 2) The circumball about CENTER must not contain any points in PTS in its +! interior (Delaunay property). +! +! The above are necessary and sufficient conditions for flipping the +! Delaunay simplex, given that F is indeed a Delaunay facet. +! +! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices +! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex +! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and +! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were +! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an +! extrapolation point (not a convex combination of points in PTS). + +! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed +! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. +! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal +! vector is any nonzero vector in ker A, where the matrix +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. +! +! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR +! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. +! Then the last column of Q is orthogonal to the range of A^T, and in ker A. +IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. + ! Compute the QR factorization. + IPIV=0 + LQ = AT + CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 80 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! The nullspace is given by the last column of Q. + PLANE(1:D-1) = 0.0_R8 + PLANE(D) = 1.0_R8 + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & + LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 83 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Calculate the constant \alpha defining the plane. + PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) + ! Compute the sign for the side of PLANE containing Q(:,MI). + SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) + SIDE1 = SIGN(1.0_R8,SIDE1) + + ! Set the RHS to P^T B. + FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) + ! Solve R^T Q^T X = P^T B for Q^T X. + CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) + + ! Initialize the center, radius, simplex, and OpenMP variabls. + SIMPS(D+1,MI) = 0 + CENTER(:) = 0.0_R8 + CENTER_PRIV(:) = 0.0_R8 + MINRAD = HUGE(0.0_R8) + MINRAD_PRIV = HUGE(0.0_R8) + VERTEX_PRIV = 0 + + ! Begin Level 2 parallel loop over N points in PTS. + !$OMP PARALLEL & + ! + ! The FIRSTPRIVATE list specifies initialized variables, of which each + ! thread has a private copy. + !$OMP& FIRSTPRIVATE(CENTER_PRIV, LQ, MINRAD_PRIV, VERTEX_PRIV), & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(I, SIDE2, WORK), & + ! + ! The REDUCTION clause specifies a PRIVATE variable that will retain + ! some value (i.e., max, min, sum, etc.) upon output. + !$OMP& REDUCTION(MAX:IERR_PRIV), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& IF(PLVL2) + + ! Initialize the error flag. + IERR_PRIV = 0 + !$OMP DO SCHEDULE(STATIC) + DO I = 1, N + IF(IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. + ! Check that P* is inside the current ball. + IF (DNRM2(D, PTS(:,I) - CENTER_PRIV(:), 1) > MINRAD_PRIV) CYCLE + ! Check that P* is on the appropriate halfspace. + SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) + IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE + ! Perform a rank-1 update to the current QR factorization of A^T by + ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the + ! final column of R. + LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) + CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & + LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + IERR_PRIV = 83; CYCLE + END IF + ! Update the last element of Q^T X. + WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) + WORK(D) = LQ(D,D) / 2.0_R8 + CENTER_PRIV(1:D-1) = X(1:D-1) + CENTER_PRIV(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) + ! Get the center by applying Q to the solution. + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER_PRIV, D, & + WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + IERR_PRIV = 83; CYCLE + END IF + ! Update the new radius, center, and simplex. + MINRAD_PRIV = DNRM2(D, CENTER_PRIV, 1) + CENTER_PRIV(:) = CENTER_PRIV(:) + PTS(:,SIMPS(1,MI)) + VERTEX_PRIV = I + END DO + !$OMP END DO + !$OMP CRITICAL(REDUC_4) + ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. + IF (VERTEX_PRIV .NE. 0) THEN + IF (DNRM2(D, PTS(:,VERTEX_PRIV) - CENTER(:), 1) < MINRAD) THEN + MINRAD = MINRAD_PRIV + CENTER(:) = CENTER_PRIV(:) + SIMPS(D+1,MI) = VERTEX_PRIV + END IF + END IF + !$OMP END CRITICAL(REDUC_4) + !$OMP END PARALLEL + ! End level 2 parallel region. + + ! Check for error flags. + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = IERR_PRIV + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Check for extrapolation condition. + IF(SIMPS(D+1,MI) .NE. 0) THEN + ! Add new point to the linear system. + AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + END IF +ELSE ! Special case where D=1. + PLANE(1) = 1.0_R8 + PLANE(2) = PTS(1,SIMPS(1,MI)) + SIDE1 = SIGN(1.0_R8, PROJ(1) - PLANE(2)) + ! Initialize the radius, simplex, and OpenMP variabls. + SIMPS(2,MI) = 0 + MINRAD = HUGE(0.0_R8) + MINRAD_PRIV = HUGE(0.0_R8) + VERTEX_PRIV = 0 + ! Begin Level 2 parallel loop over N points in PTS. + !$OMP PARALLEL & + ! + ! The FIRSTPRIVATE list specifies initialized variables, of which each + ! thread has a private copy. + !$OMP& FIRSTPRIVATE(MINRAD_PRIV, VERTEX_PRIV), & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(I, SIDE2), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& IF(PLVL2) + + !$OMP DO SCHEDULE(STATIC) + DO I = 1, N + ! Check that P* is on the appropriate halfspace. + SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 + IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE + ! Check that P* is closer than the current solution. + IF (SIDE2 > MINRAD) CYCLE + ! Update the minimum distance and save the index I. + MINRAD_PRIV = SIDE2 + VERTEX_PRIV = I + END DO + !$OMP END DO + !$OMP CRITICAL(REDUC_4) + ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. + IF (VERTEX_PRIV .NE. 0) THEN + IF (MINRAD_PRIV < MINRAD) THEN + MINRAD = MINRAD_PRIV + SIMPS(2,MI) = VERTEX_PRIV + END IF + END IF + !$OMP END CRITICAL(REDUC_4) + !$OMP END PARALLEL + ! Check for extrapolation condition. + IF(SIMPS(2,MI) .NE. 0) THEN + ! Add new point to the linear system. + AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) + B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 + END IF +END IF +! RETURN +! END SUBROUTINE MAKESIMPLEX +! End of in-lined code for MAKESIMPLEX(). +!****************************************************************************** + + + ! If no vertex was found, then this is an extrapolation point. + IF (SIMPS(D+1,MI) .EQ. 0) THEN + ! If extrapolation is not allowed (EXTRAP=0), do not proceed. + IF (IEXTRAPS < 0) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! Set the error flag and skip this point. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 2 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + + ! If extrapolation is allowed (EXTRAP>0), check the budget. + ELSE IF (IEXTRAPS .EQ. 0) THEN + ! A second projection has been attempted. This code is rarely + ! called, except in extreme cases involving nearly singular + ! simplices near the convex hull of P. + + ! Swap the weights to match the simplex indices, and zero the + ! most negative weight. + !$OMP CRITICAL(CHECK_IERR) + WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) + WEIGHTS(D+1,MI) = 0.0_R8 + !$OMP END CRITICAL(CHECK_IERR) + ! Loop through all the remaining facets from which Q(:,MI) is + ! visible, and attempt to flip across each one. + DO WHILE (SIMPS(D+1,MI) .EQ. 0) + ! Restore the previous simplex and linear system. + SIMPS(D+1,MI) = ITMP + AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + ! Find the next most negative weight. + JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) + ! Check if WEIGHTS(JTMP,MI) .GE. 0. + IF (WEIGHTS(JTMP,MI) .GE. -EPSL) THEN + ! There is no other direction to flip, so Q(:,MI) must be + ! within EPSL of the current simplex. + ! Project Q(:,MI) onto the current simplex. + + ! Since at least one projection has already been done, + ! the work arrays have already been allocated. + PRGOPT_DWNNLS(1) = 1.0_R8 + IWORK_DWNNLS(1) = 6*D + 6 + IWORK_DWNNLS(2) = 2*D + 2 + ! Set equality constraint. + W_DWNNLS(1,1:D+2) = 1.0_R8 + ! Populate LS coefficient matrix and RHS. + FORALL (I=1:D+1) W_DWNNLS(2:D+1,I) = PTS(:,SIMPS(I,MI)) + W_DWNNLS(2:D+1,D+2) = PROJ(:) + ! Project onto the current simplex. + CALL DWNNLS(W_DWNNLS, D+1, 1, D, D+1, 0, PRGOPT_DWNNLS, & + WEIGHTS(:,MI), WORK(1), IERR_PRIV, IWORK_DWNNLS, & + WORK_DWNNLS) + IF (IERR_PRIV .EQ. 1) THEN ! Failure to converge. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 71 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + ELSE IF (IERR_PRIV .EQ. 2) THEN ! Illegal input detected. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 72 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! A solution has been found; return it. + EXIT INNER + END IF + ! Otherwise, swap the vertices. + ITMP = SIMPS(JTMP,MI) + SIMPS(JTMP,MI) = SIMPS(D+1,MI) + ! Swap the weights to match, and zero the most negative weight. + !$OMP CRITICAL(CHECK_IERR) + WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) + WEIGHTS(D+1,MI) = 0.0_R8 + !$OMP END CRITICAL(CHECK_IERR) + ! If the least weighted vertex (index JTMP) is not the first vertex, + ! then just drop row (JTMP-1) from the linear system + ! (corresponding to the JTMP-1st column of A^T). + IF (JTMP .NE. 1) THEN + AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) + ! However, if JTMP=1, then both A^T and B must be reconstructed. + ELSE + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + ! Compute another simplex (try to flip again). +! CALL MAKESIMPLEX(); IF (IERR(MI) .NE. 0) CYCLE OUTER + + +!****************************************************************************** +! Due to OpenMP's handling of variable scope, the parallel implementation of +! the subroutine MAKESIMPLEX() has been in-lined here. +! +! SUBROUTINE MAKESIMPLEX() +! Given a Delaunay facet F whose containing hyperplane does not contain +! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' +! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F +! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the +! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly +! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing +! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices +! P_1, P_2, ..., P_D, P*. Then +! +! X = CENTER - P_1 +! +! is given by the solution to the nonsingular linear system +! +! A X = B where +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and +! B = [ /2, /2, ..., /2 ]^T. +! +! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the +! candidate P* that satisfies both of the following: +! +! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) +! must be on the same side of PLANE. +! +! 2) The circumball about CENTER must not contain any points in PTS in its +! interior (Delaunay property). +! +! The above are necessary and sufficient conditions for flipping the +! Delaunay simplex, given that F is indeed a Delaunay facet. +! +! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices +! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex +! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and +! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were +! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an +! extrapolation point (not a convex combination of points in PTS). + +! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed +! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. +! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal +! vector is any nonzero vector in ker A, where the matrix +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. +! +! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR +! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. +! Then the last column of Q is orthogonal to the range of A^T, and in ker A. +IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. + ! Compute the QR factorization. + IPIV=0 + LQ = AT + CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 80 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! The nullspace is given by the last column of Q. + PLANE(1:D-1) = 0.0_R8 + PLANE(D) = 1.0_R8 + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & + LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 83 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Calculate the constant \alpha defining the plane. + PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) + ! Compute the sign for the side of PLANE containing Q(:,MI). + SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) + SIDE1 = SIGN(1.0_R8,SIDE1) + ! Set the RHS to P^T B. + FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) + ! Solve R^T Q^T X = P^T B for Q^T X. + CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) + ! Initialize the center, radius, simplex, and OpenMP variabls. + SIMPS(D+1,MI) = 0 + CENTER(:) = 0.0_R8 + CENTER_PRIV(:) = 0.0_R8 + MINRAD = HUGE(0.0_R8) + MINRAD_PRIV = HUGE(0.0_R8) + VERTEX_PRIV = 0 + + ! Begin Level 2 parallel loop over N points in PTS. + !$OMP PARALLEL & + ! + ! The FIRSTPRIVATE list specifies initialized variables, of which each + ! thread has a private copy. + !$OMP& FIRSTPRIVATE(CENTER_PRIV, LQ, MINRAD_PRIV, VERTEX_PRIV), & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(I, SIDE2, WORK), & + ! + ! The REDUCTION clause specifies a PRIVATE variable that will retain + ! some value (i.e., max, min, sum, etc.) upon output. + !$OMP& REDUCTION(MAX:IERR_PRIV), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& IF(PLVL2) + + ! Initialize the error flag. + IERR_PRIV = 0 + !$OMP DO SCHEDULE(STATIC) + DO I = 1, N + IF(IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. + ! Check that P* is inside the current ball. + IF (DNRM2(D, PTS(:,I) - CENTER_PRIV(:), 1) > MINRAD_PRIV) CYCLE + ! Check that P* is on the appropriate halfspace. + SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) + IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE + ! Perform a rank-1 update to the current QR factorization of A^T by + ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the + ! final column of R. + LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) + CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & + LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + IERR_PRIV = 83; CYCLE + END IF + ! Update the last element of Q^T X. + WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) + WORK(D) = LQ(D,D) / 2.0_R8 + CENTER_PRIV(1:D-1) = X(1:D-1) + CENTER_PRIV(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) + ! Get the center by applying Q to the solution. + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER_PRIV, D, & + WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + IERR_PRIV = 83; CYCLE + END IF + ! Update the new radius, center, and simplex. + MINRAD_PRIV = DNRM2(D, CENTER_PRIV, 1) + CENTER_PRIV(:) = CENTER_PRIV(:) + PTS(:,SIMPS(1,MI)) + VERTEX_PRIV = I + END DO + !$OMP END DO + !$OMP CRITICAL(REDUC_4) + ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. + IF (VERTEX_PRIV .NE. 0) THEN + IF (DNRM2(D, PTS(:,VERTEX_PRIV) - CENTER(:), 1) < MINRAD) THEN + MINRAD = MINRAD_PRIV + CENTER(:) = CENTER_PRIV(:) + SIMPS(D+1,MI) = VERTEX_PRIV + END IF + END IF + !$OMP END CRITICAL(REDUC_4) + !$OMP END PARALLEL + ! End level 2 parallel region. + + ! Check for error flags. + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = IERR_PRIV + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Check for extrapolation condition. + IF(SIMPS(D+1,MI) .NE. 0) THEN + ! Add new point to the linear system. + AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + END IF +ELSE ! Special case where D=1. + PLANE(1) = 1.0_R8 + PLANE(2) = PTS(1,SIMPS(1,MI)) + SIDE1 = SIGN(1.0_R8, PROJ(1) - PLANE(2)) + ! Initialize the radius, simplex, and OpenMP variabls. + SIMPS(2,MI) = 0 + MINRAD = HUGE(0.0_R8) + MINRAD_PRIV = HUGE(0.0_R8) + VERTEX_PRIV = 0 + ! Begin Level 2 parallel loop over N points in PTS. + !$OMP PARALLEL & + ! + ! The FIRSTPRIVATE list specifies initialized variables, of which each + ! thread has a private copy. + !$OMP& FIRSTPRIVATE(MINRAD_PRIV, VERTEX_PRIV), & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(I, SIDE2), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& IF(PLVL2) + + !$OMP DO SCHEDULE(STATIC) + DO I = 1, N + ! Check that P* is on the appropriate halfspace. + SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 + IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE + ! Check that P* is closer than the current solution. + IF (SIDE2 > MINRAD) CYCLE + ! Update the minimum distance and save the index I. + MINRAD_PRIV = SIDE2 + VERTEX_PRIV = I + END DO + !$OMP END DO + !$OMP CRITICAL(REDUC_4) + ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. + IF (VERTEX_PRIV .NE. 0) THEN + IF (MINRAD_PRIV < MINRAD) THEN + MINRAD = MINRAD_PRIV + SIMPS(2,MI) = VERTEX_PRIV + END IF + END IF + !$OMP END CRITICAL(REDUC_4) + !$OMP END PARALLEL + ! Check for extrapolation condition. + IF(SIMPS(2,MI) .NE. 0) THEN + ! Add new point to the linear system. + AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) + B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 + END IF +END IF +! RETURN +! END SUBROUTINE MAKESIMPLEX +! End of in-lined code for MAKESIMPLEX(). +!****************************************************************************** + + + END DO + ! If the loop terminates, then a good direction was found. + ! Resume the visibility walk as normal. + CYCLE INNER + END IF + + ! Otherwise, project the extrapolation point onto the convex hull. +! CALL PROJECT(); IF (IERR_PRIV .NE. 0) CYCLE OUTER + + +!****************************************************************************** +! Due to OpenMP's handling of variable scope, the parallel (identical to serial) +! implementation of the subroutine PROJECT() has been in-lined here. +! +! SUBROUTINE PROJECT() +! Project a point outside the convex hull of the point set onto the convex hull +! by solving an inequality constrained least squares problem. The solution to +! the least squares problem gives the projection as a convex combination of the +! data points. The projection can then be computed by performing a matrix +! vector multiplication. + +! Allocate work arrays. +IF (.NOT. ALLOCATED(IWORK_DWNNLS)) THEN + ALLOCATE(IWORK_DWNNLS(D+1+N), STAT=IERR_PRIV) + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 70 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF +END IF +IF (.NOT. ALLOCATED(WORK_DWNNLS)) THEN + ALLOCATE(WORK_DWNNLS(D+1+N*5), STAT=IERR_PRIV) + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 70 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF +END IF +IF (.NOT. ALLOCATED(W_DWNNLS)) THEN + ALLOCATE(W_DWNNLS(D+1,N+1), STAT=IERR_PRIV) + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 70 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF +END IF +IF (.NOT. ALLOCATED(X_DWNNLS)) THEN + ALLOCATE(X_DWNNLS(N), STAT=IERR_PRIV) + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 70 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF +END IF + +! Initialize work array and settings values. +IWORK_DWNNLS(1) = D+1+5*N +IWORK_DWNNLS(2) = D+1+N +W_DWNNLS(1, :) = 1.0_R8 ! Set convexity (equality) constraint. +W_DWNNLS(2:D+1,1:N) = PTS(:,:) ! Copy data points. +W_DWNNLS(2:D+1,N+1) = PROJ(:) ! Copy extrapolation point. +! Compute the solution to the inequality constrained least squares problem to +! get the projection coefficients. +CALL DWNNLS(W_DWNNLS, D+1, 1, D, N, 0, PRGOPT_DWNNLS, X_DWNNLS, RNORML, & + IERR_PRIV, IWORK_DWNNLS, WORK_DWNNLS) +IF (IERR_PRIV .EQ. 1) THEN ! Failure to converge. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 71 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER +ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 72 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER +END IF +! Compute the actual projection via matrix vector multiplication. +CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) +! Zero all weights that are approximately zero and renormalize the sum. +WHERE (X_DWNNLS < EPSL) X_DWNNLS = 0.0_R8 +X_DWNNLS(:) = X_DWNNLS(:) / SUM(X_DWNNLS) +! Compute the actual projection via matrix vector multiplication. +CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) +RNORML = DNRM2(D, PROJ(:) - Q(:,MI), 1) +! RETURN +! END SUBROUTINE PROJECT +! End of in-lined code for PROJECT(). +!****************************************************************************** + + + ! Check the value of RNORML for over-extrapolation. + IF (RNORML > EXTRAPL * PTS_DIAM) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! If present, record the unscaled RNORM output. + IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE + ! Set the error flag and skip this point. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 2 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + + ! Otherwise, restore the previous simplex and continue with the + ! projected value. + SIMPS(D+1,MI) = ITMP + AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + IEXTRAPS = IEXTRAPS - 1 ! Decrement the budget. + END IF + + ! End of inner loop for finding each interpolation point. + END DO INNER + + ! Check for budget violation conditions. + IF (K > IBUDGETL) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! Set the error flag and skip this point. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 60 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + + ! If the residual is nonzero, set the extrapolation flag. + IF (RNORML > EPSL) THEN + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 1 + !$OMP END CRITICAL(CHECK_IERR) + END IF + + ! If present, record the RNORM output. + IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE + +END DO OUTER ! End of outer loop over all interpolation points. +!$OMP END DO + +! If INTERP_IN and INTERP_OUT are present, compute all values f(q). +IF (PRESENT(INTERP_IN)) THEN + ! Level 1 parallel loop over all interpolation points. + !$OMP DO SCHEDULE(STATIC) + DO MI = 1, M + ! Check for errors. + IF (IERR(MI) .LE. 1) THEN + ! Compute the weighted sum of vertex response values. + DO K = 1, D+1 + INTERP_OUT(:,MI) = INTERP_OUT(:,MI) & + + INTERP_IN(:,SIMPS(K,MI)) * WEIGHTS(K,MI) + END DO + END IF + END DO + !$OMP END DO +END IF + +! Free optional work arrays. +IF (ALLOCATED(IWORK_DWNNLS)) DEALLOCATE(IWORK_DWNNLS) +IF (ALLOCATED(WORK_DWNNLS)) DEALLOCATE(WORK_DWNNLS) +IF (ALLOCATED(W_DWNNLS)) DEALLOCATE(W_DWNNLS) +IF (ALLOCATED(X_DWNNLS)) DEALLOCATE(X_DWNNLS) +!$OMP END PARALLEL +! End of Level 1 parallel region. + +! Free dynamic work arrays. +DEALLOCATE(WORK) + +RETURN + +CONTAINS ! Internal subroutines and functions. + +SUBROUTINE RESCALE(MINDIST, DIAMETER, SCALE) +! Rescale and transform data to be centered at the origin with unit +! radius. +! +! The parallel implementation of this subroutine exploits parallelism +! over loops of length N. For nested loops, this subroutine follows +! the OpenMP recommendation of a static schedule with a fixed chunk +! size (of 100). +! +! On output, PTS and Q have been rescaled and shifted. All the data +! points in PTS are centered with unit radius, and the points in Q +! have been shifted and scaled in relation to PTS. +! +! MINDIST is a real number containing the (scaled) minimum distance +! between any two data points in PTS. +! +! DIAMETER is a real number containing the (scaled) diameter of the +! data set PTS. +! +! SCALE contains the real factor used to transform the data and +! interpolation points: scaled value = (original value - +! barycenter of data points)/SCALE. + +! Output arguments. +REAL(KIND=R8), INTENT(OUT) :: MINDIST, DIAMETER, SCALE + +! Local variables. +REAL(KIND=R8) :: PTS_CENTER(D) ! The center of the data points PTS. +REAL(KIND=R8) :: DISTANCE ! The current distance. + +! Initialize local values. +MINDIST = HUGE(0.0_R8) +DIAMETER = 0.0_R8 +SCALE = 0.0_R8 + +! Compute barycenter of all data points. +PTS_CENTER(:) = SUM(PTS(:,:), DIM=2)/REAL(N, KIND=R8) +! Center the points. +FORALL (I = 1:N) PTS(:,I) = PTS(:,I) - PTS_CENTER(:) +! Compute the scale factor (for unit radius). +!$OMP PARALLEL DO & +!$OMP& PRIVATE(I, DISTANCE), & +!$OMP& REDUCTION(MAX:SCALE), & +!$OMP& SCHEDULE(STATIC), & +!$OMP& DEFAULT(SHARED) +DO I = 1, N ! Cycle through all points again. + DISTANCE = DNRM2(D, PTS(:,I), 1) ! Compute the distance from the center. + IF (DISTANCE > SCALE) THEN ! Compare to the current radius. + SCALE = DISTANCE + END IF +END DO +!$OMP END PARALLEL DO +! Scale the points to unit radius. +PTS = PTS / SCALE +! Also transform Q similarly. +FORALL (I = 1:M) Q(:,I) = (Q(:,I) - PTS_CENTER(:)) / SCALE +! Compute the minimum and maximum distances. +IF (EXACTL) THEN + ! If exact error error checking is turned on, then compute the DIAMETER + ! and MINDIST values. + !$OMP PARALLEL DO & + !$OMP& PRIVATE(I, DISTANCE), & + !$OMP& REDUCTION(MAX:DIAMETER), & + !$OMP& REDUCTION(MIN:MINDIST), & + !$OMP& SCHEDULE(STATIC, 100), & + !$OMP& DEFAULT(SHARED) + DO I = 1, N ! Cycle through all pairs of points. + DO J = I + 1, N + DISTANCE = DNRM2(D, PTS(:,I) - PTS(:,J), 1) ! Compute the distance. + IF (DISTANCE > DIAMETER) THEN ! Compare to the current diameter. + DIAMETER = DISTANCE + END IF + IF (DISTANCE < MINDIST) THEN ! Compare to the current minimum distance. + MINDIST = DISTANCE + END IF + END DO + END DO + !$OMP END PARALLEL DO +ELSE + ! If exact error checking is turned off, then the diameter is approximately + ! 2.0 after rescaling and centering the points. The MINDIST is not computed. + DIAMETER = 2.0_R8 + MINDIST = 1.0_R8 +END IF +RETURN +END SUBROUTINE RESCALE + +END SUBROUTINE DELAUNAYSPARSEP diff --git a/toms1012/lapack.f b/toms1012/lapack.f new file mode 100644 index 0000000..3dff8b8 --- /dev/null +++ b/toms1012/lapack.f @@ -0,0 +1,4369 @@ + SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, +* -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER INB, INBMIN, IXOVER + PARAMETER( INB = 1, INBMIN = 2, IXOVER = 3 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, + $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN +* .. +* .. External Subroutines .. + EXTERNAL DGEQRF, DLAQP2, DLAQPS, DORMQR, DSWAP, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DNRM2 + EXTERNAL ILAENV, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE + IWS = 3*N + 1 + NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = 2*N + ( N + 1 )*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQP3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Move initial columns up front. +* + NFXD = 1 + DO 10 J = 1, N + IF( JPVT( J ).NE.0 ) THEN + IF( J.NE.NFXD ) THEN + CALL DSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 ) + JPVT( J ) = JPVT( NFXD ) + JPVT( NFXD ) = J + ELSE + JPVT( J ) = J + END IF + NFXD = NFXD + 1 + ELSE + JPVT( J ) = J + END IF + 10 CONTINUE + NFXD = NFXD - 1 +* +* Factorize fixed columns +* ======================= +* +* Compute the QR factorization of fixed columns and update +* remaining columns. +* + IF( NFXD.GT.0 ) THEN + NA = MIN( M, NFXD ) +*CC CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) + CALL DGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO ) + IWS = MAX( IWS, INT( WORK( 1 ) ) ) + IF( NA.LT.N ) THEN +*CC CALL DORM2R( 'LEFT', 'TRANSPOSE', M, N-NA, NA, A, LDA, +*CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) + CALL DORMQR( 'LEFT', 'TRANSPOSE', M, N-NA, NA, A, LDA, TAU, + $ A( 1, NA+1 ), LDA, WORK, LWORK, INFO ) + IWS = MAX( IWS, INT( WORK( 1 ) ) ) + END IF + END IF +* +* Factorize free columns +* ====================== +* + IF( NFXD.LT.MINMN ) THEN +* + SM = M - NFXD + SN = N - NFXD + SMINMN = MINMN - NFXD +* +* Determine the block size. +* + NB = ILAENV( INB, 'DGEQRF', ' ', SM, SN, -1, -1 ) + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked +* code. +* + NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', SM, SN, -1, + $ -1 ) ) +* +* + IF( NX.LT.SMINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + MINWS = 2*SN + ( SN+1 )*NB + IWS = MAX( IWS, MINWS ) + IF( LWORK.LT.MINWS ) THEN +* +* Not enough workspace to use optimal NB: Reduce NB and +* determine the minimum value of NB. +* + NB = ( LWORK-2*SN ) / ( SN+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', SM, N, + $ -1, -1 ) ) +* +* + END IF + END IF + END IF +* +* Initialize partial column norms. The first N elements of work +* store the exact column norms. +* + DO 20 J = NFXD + 1, N + WORK( J ) = DNRM2( SM, A( NFXD+1, J ), 1 ) + WORK( N+J ) = WORK( J ) + 20 CONTINUE +* + IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. + $ ( NX.LT.SMINMN ) ) THEN +* +* Use blocked code initially. +* + J = NFXD + 1 +* +* Compute factorization: while loop. +* +* + TOPBMN = MINMN - NX + 30 CONTINUE + IF( J.LE.TOPBMN ) THEN + JB = MIN( NB, TOPBMN-J+1 ) +* +* Factorize JB columns among columns J:N. +* + CALL DLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, + $ JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 ) +* + J = J + FJB + GO TO 30 + END IF + ELSE + J = NFXD + 1 + END IF +* +* Use unblocked code to factor the last or only block. +* +* + IF( J.LE.MINMN ) + $ CALL DLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), + $ TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ) ) +* + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of DGEQP3 +* + END + SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DGEQR2 computes a QR factorization of a real m by n matrix A: +* A = Q * R. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the m by n matrix A. +* On exit, the elements on and above the diagonal of the array +* contain the min(m,n) by n upper trapezoidal matrix R (R is +* upper triangular if m >= n); the elements below the diagonal, +* with the array TAU, represent the orthogonal matrix Q as a +* product of elementary reflectors (see Further Details). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) +* The scalar factors of the elementary reflectors (see Further +* Details). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further Details +* =============== +* +* The matrix Q is represented as a product of elementary reflectors +* +* Q = H(1) H(2) . . . H(k), where k = min(m,n). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**T +* +* where tau is a real scalar, and v is a real vector with +* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), +* and tau in TAU(i). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K + DOUBLE PRECISION AII +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQR2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = 1, K +* +* Generate elementary reflector H(i) to annihilate A(i+1:m,i) +* + CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, + $ TAU( I ) ) + IF( I.LT.N ) THEN +* +* Apply H(i) to A(i:m,i+1:n) from the left +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + A( I, I ) = AII + END IF + 10 CONTINUE + RETURN +* +* End of DGEQR2 +* + END + SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DGEQRF computes a QR factorization of a real M-by-N matrix A: +* A = Q * R. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the M-by-N matrix A. +* On exit, the elements on and above the diagonal of the array +* contain the min(M,N)-by-N upper trapezoidal matrix R (R is +* upper triangular if m >= n); the elements below the diagonal, +* with the array TAU, represent the orthogonal matrix Q as a +* product of min(m,n) elementary reflectors (see Further +* Details). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) +* The scalar factors of the elementary reflectors (see Further +* Details). +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension +* (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= max(1,N). +* For optimum performance LWORK >= N*NB, where NB is +* the optimal blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further Details +* =============== +* +* The matrix Q is represented as a product of elementary reflectors +* +* Q = H(1) H(2) . . . H(k), where k = min(m,n). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**T +* +* where tau is a real scalar, and v is a real vector with +* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), +* and tau in TAU(i). +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQRF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + K = MIN( M, N ) + IF( K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, + $ -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code initially +* + DO 10 I = 1, K - NX, NB + IB = MIN( K-I+1, NB ) +* +* Compute the QR factorization of the current block +* A(i:m,i:i+ib-1) +* + CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) + IF( I+IB.LE.N ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, + $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H**T to A(i:m,i+ib:n) from the left +* + CALL DLARFB( 'Left', 'Transpose', 'Forward', + $ 'Columnwise', M-I+1, N-I-IB+1, IB, + $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), + $ LDA, WORK( IB+1 ), LDWORK ) + END IF + 10 CONTINUE + ELSE + I = 1 + END IF +* +* Use unblocked code to factor the last or only block. +* + IF( I.LE.K ) + $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* + WORK( 1 ) = IWS + RETURN +* +* End of DGEQRF +* + END + SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DGETF2 computes an LU factorization of a general m-by-n matrix A +* using partial pivoting with row interchanges. +* +* The factorization has the form +* A = P * L * U +* where P is a permutation matrix, L is lower triangular with unit +* diagonal elements (lower trapezoidal if m > n), and U is upper +* triangular (upper trapezoidal if m < n). +* +* This is the right-looking Level 2 BLAS version of the algorithm. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the m by n matrix to be factored. +* On exit, the factors L and U from the factorization +* A = P*L*U; the unit diagonal elements of L are not stored. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* IPIV (output) INTEGER array, dimension (min(M,N)) +* The pivot indices; for 1 <= i <= min(M,N), row i of the +* matrix was interchanged with row IPIV(i). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -k, the k-th argument had an illegal value +* > 0: if INFO = k, U(k,k) is exactly zero. The factorization +* has been completed, but the factor U is exactly +* singular, and division by zero will occur if it is used +* to solve a system of equations. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION SFMIN + INTEGER I, J, JP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER IDAMAX + EXTERNAL DLAMCH, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL DGER, DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Compute machine safe minimum +* + SFMIN = DLAMCH('S') +* + DO 10 J = 1, MIN( M, N ) +* +* Find pivot and test for singularity. +* + JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) + IPIV( J ) = JP + IF( A( JP, J ).NE.ZERO ) THEN +* +* Apply the interchange to columns 1:N. +* + IF( JP.NE.J ) + $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) +* +* Compute elements J+1:M of J-th column. +* + IF( J.LT.M ) THEN + IF( ABS(A( J, J )) .GE. SFMIN ) THEN + CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) + ELSE + DO 20 I = 1, M-J + A( J+I, J ) = A( J+I, J ) / A( J, J ) + 20 CONTINUE + END IF + END IF +* + ELSE IF( INFO.EQ.0 ) THEN +* + INFO = J + END IF +* + IF( J.LT.MIN( M, N ) ) THEN +* +* Update trailing submatrix. +* + CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, + $ A( J+1, J+1 ), LDA ) + END IF + 10 CONTINUE + RETURN +* +* End of DGETF2 +* + END + SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DGETRF computes an LU factorization of a general M-by-N matrix A +* using partial pivoting with row interchanges. +* +* The factorization has the form +* A = P * L * U +* where P is a permutation matrix, L is lower triangular with unit +* diagonal elements (lower trapezoidal if m > n), and U is upper +* triangular (upper trapezoidal if m < n). +* +* This is the right-looking Level 3 BLAS version of the algorithm. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the M-by-N matrix to be factored. +* On exit, the factors L and U from the factorization +* A = P*L*U; the unit diagonal elements of L are not stored. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* IPIV (output) INTEGER array, dimension (min(M,N)) +* The pivot indices; for 1 <= i <= min(M,N), row i of the +* matrix was interchanged with row IPIV(i). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, U(i,i) is exactly zero. The factorization +* has been completed, but the factor U is exactly +* singular, and division by zero will occur if it is used +* to solve a system of equations. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IINFO, J, JB, NB +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN +* +* Use unblocked code. +* + CALL DGETF2( M, N, A, LDA, IPIV, INFO ) + ELSE +* +* Use blocked code. +* + DO 20 J = 1, MIN( M, N ), NB + JB = MIN( MIN( M, N )-J+1, NB ) +* +* Factor diagonal and subdiagonal blocks and test for exact +* singularity. +* + CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) +* +* Adjust INFO and the pivot indices. +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + J - 1 + DO 10 I = J, MIN( M, J+JB-1 ) + IPIV( I ) = J - 1 + IPIV( I ) + 10 CONTINUE +* +* Apply interchanges to columns 1:J-1. +* + CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) +* + IF( J+JB.LE.N ) THEN +* +* Apply interchanges to columns J+JB:N. +* + CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, + $ IPIV, 1 ) +* +* Compute block row of U. +* + CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, + $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), + $ LDA ) + IF( J+JB.LE.M ) THEN +* +* Update trailing submatrix. +* + CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, + $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, + $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), + $ LDA ) + END IF + END IF + 20 CONTINUE + END IF + RETURN +* +* End of DGETRF +* + END + SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* Purpose +* ======= +* +* DGETRS solves a system of linear equations +* A * X = B or A**T * X = B +* with a general N-by-N matrix A using the LU factorization computed +* by DGETRF. +* +* Arguments +* ========= +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T* X = B (Transpose) +* = 'C': A**T* X = B (Conjugate transpose = Transpose) +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrix B. NRHS >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The factors L and U from the factorization A = P*L*U +* as computed by DGETRF. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* IPIV (input) INTEGER array, dimension (N) +* The pivot indices from DGETRF; for 1<=i<=N, row i of the +* matrix was interchanged with row IPIV(i). +* +* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) +* On entry, the right hand side matrix B. +* On exit, the solution matrix X. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLASWP, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( NOTRAN ) THEN +* +* Solve A * X = B. +* +* Apply row interchanges to the right hand sides. +* + CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) +* +* Solve L*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve U*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, A, LDA, B, LDB ) + ELSE +* +* Solve A**T * X = B. +* +* Solve U**T *X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve L**T *X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, + $ A, LDA, B, LDB ) +* +* Apply row interchanges to the solution vectors. +* + CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) + END IF +* + RETURN +* +* End of DGETRS +* + END + DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y +* .. +* +* Purpose +* ======= +* +* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary +* overflow. +* +* Arguments +* ========= +* +* X (input) DOUBLE PRECISION +* Y (input) DOUBLE PRECISION +* X and Y specify the values x and y. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION W, XABS, YABS, Z +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + XABS = ABS( X ) + YABS = ABS( Y ) + W = MAX( XABS, YABS ) + Z = MIN( XABS, YABS ) + IF( Z.EQ.ZERO ) THEN + DLAPY2 = W + ELSE + DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) + END IF + RETURN +* +* End of DLAPY2 +* + END + SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, + $ WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, +* -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER LDA, M, N, OFFSET +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, MN, OFFPI, PVT + DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 +* .. +* .. Executable Statements .. +* + MN = MIN( M-OFFSET, N ) + TOL3Z = SQRT(DLAMCH('EPSILON')) +* +* Compute factorization. +* + DO 20 I = 1, MN +* + OFFPI = OFFSET + I +* +* Determine ith pivot column and swap if necessary. +* + PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 ) +* + IF( PVT.NE.I ) THEN + CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( I ) + JPVT( I ) = ITEMP + VN1( PVT ) = VN1( I ) + VN2( PVT ) = VN2( I ) + END IF +* +* Generate elementary reflector H(i). +* + IF( OFFPI.LT.M ) THEN + CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, + $ TAU( I ) ) + ELSE + CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) + END IF +* + IF( I.LT.N ) THEN +* +* Apply H(i)**T to A(offset+i:m,i+1:n) from the left. +* + AII = A( OFFPI, I ) + A( OFFPI, I ) = ONE + CALL DLARF( 'LEFT', M-OFFPI+1, N-I, A( OFFPI, I ), 1, + $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) + A( OFFPI, I ) = AII + END IF +* +* Update partial column norms. +* + DO 10 J = I + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following 4 lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN + IF( OFFPI.LT.M ) THEN + VN1( J ) = DNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) + VN2( J ) = VN1( J ) + ELSE + VN1( J ) = ZERO + VN2( J ) = ZERO + END IF + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + 10 CONTINUE +* + 20 CONTINUE +* + RETURN +* +* End of DLAQP2 +* + END + SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, + $ VN2, AUXV, F, LDF ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, +* -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER KB, LDA, LDF, M, N, NB, OFFSET +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), + $ VN1( * ), VN2( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK + DOUBLE PRECISION AKK, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, NINT, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 +* .. +* .. Executable Statements .. +* + LASTRK = MIN( M, N+OFFSET ) + LSTICC = 0 + K = 0 + TOL3Z = SQRT(DLAMCH('EPSILON')) +* +* Beginning of while loop. +* + 10 CONTINUE + IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN + K = K + 1 + RK = OFFSET + K +* +* Determine ith pivot column and swap if necessary +* + PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) + IF( PVT.NE.K ) THEN + CALL DSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 ) + CALL DSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( K ) + JPVT( K ) = ITEMP + VN1( PVT ) = VN1( K ) + VN2( PVT ) = VN2( K ) + END IF +* +* Apply previous Householder reflectors to column K: +* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**T. +* + IF( K.GT.1 ) THEN + CALL DGEMV( 'NO TRANSPOSE', M-RK+1, K-1, -ONE, A( RK, 1 ), + $ LDA, F( K, 1 ), LDF, ONE, A( RK, K ), 1 ) + END IF +* +* Generate elementary reflector H(k). +* + IF( RK.LT.M ) THEN + CALL DLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) + ELSE + CALL DLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) + END IF +* + AKK = A( RK, K ) + A( RK, K ) = ONE +* +* Compute Kth column of F: +* +* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**T*A(RK:M,K). +* + IF( K.LT.N ) THEN + CALL DGEMV( 'TRANSPOSE', M-RK+1, N-K, TAU( K ), + $ A( RK, K+1 ), LDA, A( RK, K ), 1, ZERO, + $ F( K+1, K ), 1 ) + END IF +* +* Padding F(1:K,K) with zeros. +* + DO 20 J = 1, K + F( J, K ) = ZERO + 20 CONTINUE +* +* Incremental updating of F: +* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**T +* *A(RK:M,K). +* + IF( K.GT.1 ) THEN + CALL DGEMV( 'TRANSPOSE', M-RK+1, K-1, -TAU( K ), A( RK, 1 ), + $ LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 ) +* + CALL DGEMV( 'NO TRANSPOSE', N, K-1, ONE, F( 1, 1 ), LDF, + $ AUXV( 1 ), 1, ONE, F( 1, K ), 1 ) + END IF +* +* Update the current row of A: +* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**T. +* + IF( K.LT.N ) THEN + CALL DGEMV( 'NO TRANSPOSE', N-K, K, -ONE, F( K+1, 1 ), LDF, + $ A( RK, 1 ), LDA, ONE, A( RK, K+1 ), LDA ) + END IF +* +* Update partial column norms. +* + IF( RK.LT.LASTRK ) THEN + DO 30 J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following 4 lines follow from the analysis +* in +* Lapack Working Note 176. +* + TEMP = ABS( A( RK, J ) ) / VN1( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN + VN2( J ) = DBLE( LSTICC ) + LSTICC = J + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE + END IF +* + A( RK, K ) = AKK +* +* End of while loop. +* + GO TO 10 + END IF + KB = K + RK = OFFSET + KB +* +* Apply the block reflector to the rest of the matrix: +* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - +* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**T. +* + IF( KB.LT.MIN( N, M-OFFSET ) ) THEN + CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M-RK, N-KB, KB, -ONE, + $ A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, + $ A( RK+1, KB+1 ), LDA ) + END IF +* +* Recomputation of difficult columns. +* + 40 CONTINUE + IF( LSTICC.GT.0 ) THEN + ITEMP = NINT( VN2( LSTICC ) ) + VN1( LSTICC ) = DNRM2( M-RK, A( RK+1, LSTICC ), 1 ) +* +* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* SNRM2 does not fail on vectors with norm below the value of +* SQRT(DLAMCH('S')) +* + VN2( LSTICC ) = VN1( LSTICC ) + LSTICC = ITEMP + GO TO 40 + END IF +* + RETURN +* +* End of DLAQPS +* + END + SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DLARF applies a real elementary reflector H to a real m by n matrix +* C, from either the left or the right. H is represented in the form +* +* H = I - tau * v * v**T +* +* where tau is a real scalar and v is a real vector. +* +* If tau = 0, then H is taken to be the unit matrix. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': form H * C +* = 'R': form C * H +* +* M (input) INTEGER +* The number of rows of the matrix C. +* +* N (input) INTEGER +* The number of columns of the matrix C. +* +* V (input) DOUBLE PRECISION array, dimension +* (1 + (M-1)*abs(INCV)) if SIDE = 'L' +* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +* The vector v in the representation of H. V is not used if +* TAU = 0. +* +* INCV (input) INTEGER +* The increment between elements of v. INCV <> 0. +* +* TAU (input) DOUBLE PRECISION +* The value tau in the representation of H. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m by n matrix C. +* On exit, C is overwritten by the matrix H * C if SIDE = 'L', +* or C * H if SIDE = 'R'. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension +* (N) if SIDE = 'L' +* or (M) if SIDE = 'R' +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILADLR, ILADLC + EXTERNAL LSAME, ILADLR, ILADLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 0 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V. + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILADLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILADLR(M, LASTV, C, LDC) + END IF + END IF +! Note that lastc.eq.0 renders the BLAS operations null; no special +! case is needed at this level. + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) +* + CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, + $ ZERO, WORK, 1 ) +* +* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * +* w(1:lastc,1)**T +* + CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) +* + CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, + $ V, INCV, ZERO, WORK, 1 ) +* +* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * +* v(1:lastv,1)**T +* + CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) + END IF + END IF + RETURN +* +* End of DLARF +* + END + SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, + $ T, LDT, C, LDC, WORK, LDWORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), + $ WORK( LDWORK, * ) +* .. +* +* Purpose +* ======= +* +* DLARFB applies a real block reflector H or its transpose H**T to a +* real m by n matrix C, from either the left or the right. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply H or H**T from the Left +* = 'R': apply H or H**T from the Right +* +* TRANS (input) CHARACTER*1 +* = 'N': apply H (No transpose) +* = 'T': apply H**T (Transpose) +* +* DIRECT (input) CHARACTER*1 +* Indicates how H is formed from a product of elementary +* reflectors +* = 'F': H = H(1) H(2) . . . H(k) (Forward) +* = 'B': H = H(k) . . . H(2) H(1) (Backward) +* +* STOREV (input) CHARACTER*1 +* Indicates how the vectors which define the elementary +* reflectors are stored: +* = 'C': Columnwise +* = 'R': Rowwise +* +* M (input) INTEGER +* The number of rows of the matrix C. +* +* N (input) INTEGER +* The number of columns of the matrix C. +* +* K (input) INTEGER +* The order of the matrix T (= the number of elementary +* reflectors whose product defines the block reflector). +* +* V (input) DOUBLE PRECISION array, dimension +* (LDV,K) if STOREV = 'C' +* (LDV,M) if STOREV = 'R' and SIDE = 'L' +* (LDV,N) if STOREV = 'R' and SIDE = 'R' +* The matrix V. See Further Details. +* +* LDV (input) INTEGER +* The leading dimension of the array V. +* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); +* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); +* if STOREV = 'R', LDV >= K. +* +* T (input) DOUBLE PRECISION array, dimension (LDT,K) +* The triangular k by k matrix T in the representation of the +* block reflector. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= K. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m by n matrix C. +* On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) +* +* LDWORK (input) INTEGER +* The leading dimension of the array WORK. +* If SIDE = 'L', LDWORK >= max(1,N); +* if SIDE = 'R', LDWORK >= max(1,M). +* +* Further Details +* =============== +* +* The shape of the matrix V and the storage of the vectors which define +* the H(i) is best illustrated by the following example with n = 5 and +* k = 3. The elements equal to 1 are not stored; the corresponding +* array elements are modified but restored on exit. The rest of the +* array is not used. +* +* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +* +* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +* ( v1 1 ) ( 1 v2 v2 v2 ) +* ( v1 v2 1 ) ( 1 v3 v3 ) +* ( v1 v2 v3 ) +* ( v1 v2 v3 ) +* +* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +* +* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +* ( v1 v2 v3 ) ( v2 v2 v2 1 ) +* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +* ( 1 v3 ) +* ( 1 ) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + CHARACTER TRANST + INTEGER I, J, LASTV, LASTC +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILADLR, ILADLC + EXTERNAL LSAME, ILADLR, ILADLC +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DTRMM +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* + IF( LSAME( TRANS, 'N' ) ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* + IF( LSAME( STOREV, 'C' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 ) (first K rows) +* ( V2 ) +* where V1 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in +* WORK) +* +* W := C1**T +* + DO 10 J = 1, K + CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 10 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2**T *V2 +* + CALL DGEMM( 'Transpose', 'No transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**T +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - V2 * W**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTV-K, LASTC, K, + $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**T +* + DO 30 J = 1, K + DO 20 I = 1, LASTC + C( J, I ) = C( J, I ) - WORK( I, J ) + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C1 +* + DO 40 J = 1, K + CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + 40 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2 * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**T +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - W * V2**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, LASTV-K, K, + $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 60 J = 1, K + DO 50 I = 1, LASTC + C( I, J ) = C( I, J ) - WORK( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + ELSE +* +* Let V = ( V1 ) +* ( V2 ) (last K rows) +* where V2 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in +* WORK) +* +* W := C2**T +* + DO 70 J = 1, K + CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, + $ WORK( 1, J ), 1 ) + 70 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1**T*V1 +* + CALL DGEMM( 'Transpose', 'No transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**T +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - V1 * W**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) + END IF +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W**T +* + DO 90 J = 1, K + DO 80 I = 1, LASTC + C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C2 +* + DO 100 J = 1, K + CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 100 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1 * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**T +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - W * V1**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, + $ ONE, C, LDC ) + END IF +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W +* + DO 120 J = 1, K + DO 110 I = 1, LASTC + C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) + 110 CONTINUE + 120 CONTINUE + END IF + END IF +* + ELSE IF( LSAME( STOREV, 'R' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 V2 ) (V1: first K columns) +* where V1 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) +* (stored in WORK) +* +* W := C1**T +* + DO 130 J = 1, K + CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 130 CONTINUE +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2**T*V2**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**T * W**T +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - V2**T * W**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTV-K, LASTC, K, + $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, + $ ONE, C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**T +* + DO 150 J = 1, K + DO 140 I = 1, LASTC + C( J, I ) = C( J, I ) - WORK( I, J ) + 140 CONTINUE + 150 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) +* +* W := C1 +* + DO 160 J = 1, K + CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + 160 CONTINUE +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2 * V2**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - W * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, LASTV-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, + $ ONE, C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 180 J = 1, K + DO 170 I = 1, LASTC + C( I, J ) = C( I, J ) - WORK( I, J ) + 170 CONTINUE + 180 CONTINUE +* + END IF +* + ELSE +* +* Let V = ( V1 V2 ) (V2: last K columns) +* where V2 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) +* (stored in WORK) +* +* W := C2**T +* + DO 190 J = 1, K + CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, + $ WORK( 1, J ), 1 ) + 190 CONTINUE +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1**T * V1**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**T * W**T +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - V1**T * W**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W**T +* + DO 210 J = 1, K + DO 200 I = 1, LASTC + C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) + 200 CONTINUE + 210 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) +* +* W := C2 +* + DO 220 J = 1, K + CALL DCOPY( LASTC, C( 1, LASTV-K+J ), 1, + $ WORK( 1, J ), 1 ) + 220 CONTINUE +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1 * V1**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - W * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, + $ ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 240 J = 1, K + DO 230 I = 1, LASTC + C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) + 230 CONTINUE + 240 CONTINUE +* + END IF +* + END IF + END IF +* + RETURN +* +* End of DLARFB +* + END + SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION ALPHA, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* Purpose +* ======= +* +* DLARFG generates a real elementary reflector H of order n, such +* that +* +* H * ( alpha ) = ( beta ), H**T * H = I. +* ( x ) ( 0 ) +* +* where alpha and beta are scalars, and x is an (n-1)-element real +* vector. H is represented in the form +* +* H = I - tau * ( 1 ) * ( 1 v**T ) , +* ( v ) +* +* where tau is a real scalar and v is a real (n-1)-element +* vector. +* +* If the elements of x are all zero, then tau = 0 and H is taken to be +* the unit matrix. +* +* Otherwise 1 <= tau <= 2. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the elementary reflector. +* +* ALPHA (input/output) DOUBLE PRECISION +* On entry, the value alpha. +* On exit, it is overwritten with the value beta. +* +* X (input/output) DOUBLE PRECISION array, dimension +* (1+(N-2)*abs(INCX)) +* On entry, the vector x. +* On exit, it is overwritten with the vector v. +* +* INCX (input) INTEGER +* The increment between elements of X. INCX > 0. +* +* TAU (output) DOUBLE PRECISION +* The value tau. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER J, KNT + DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 + EXTERNAL DLAMCH, DLAPY2, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN +* .. +* .. External Subroutines .. + EXTERNAL DSCAL +* .. +* .. Executable Statements .. +* + IF( N.LE.1 ) THEN + TAU = ZERO + RETURN + END IF +* + XNORM = DNRM2( N-1, X, INCX ) +* + IF( XNORM.EQ.ZERO ) THEN +* +* H = I +* + TAU = ZERO + ELSE +* +* general case +* + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) + KNT = 0 + IF( ABS( BETA ).LT.SAFMIN ) THEN +* +* XNORM, BETA may be inaccurate; scale X and recompute them +* + RSAFMN = ONE / SAFMIN + 10 CONTINUE + KNT = KNT + 1 + CALL DSCAL( N-1, RSAFMN, X, INCX ) + BETA = BETA*RSAFMN + ALPHA = ALPHA*RSAFMN + IF( ABS( BETA ).LT.SAFMIN ) + $ GO TO 10 +* +* New BETA is at most 1, at least SAFMIN +* + XNORM = DNRM2( N-1, X, INCX ) + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + END IF + TAU = ( BETA-ALPHA ) / BETA + CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) +* +* If ALPHA is subnormal, it may lose relative accuracy +* + DO 20 J = 1, KNT + BETA = BETA*SAFMIN + 20 CONTINUE + ALPHA = BETA + END IF +* + RETURN +* +* End of DLARFG +* + END + SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* Purpose +* ======= +* +* DLARFT forms the triangular factor T of a real block reflector H +* of order n, which is defined as a product of k elementary reflectors. +* +* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; +* +* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. +* +* If STOREV = 'C', the vector which defines the elementary reflector +* H(i) is stored in the i-th column of the array V, and +* +* H = I - V * T * V**T +* +* If STOREV = 'R', the vector which defines the elementary reflector +* H(i) is stored in the i-th row of the array V, and +* +* H = I - V**T * T * V +* +* Arguments +* ========= +* +* DIRECT (input) CHARACTER*1 +* Specifies the order in which the elementary reflectors are +* multiplied to form the block reflector: +* = 'F': H = H(1) H(2) . . . H(k) (Forward) +* = 'B': H = H(k) . . . H(2) H(1) (Backward) +* +* STOREV (input) CHARACTER*1 +* Specifies how the vectors which define the elementary +* reflectors are stored (see also Further Details): +* = 'C': columnwise +* = 'R': rowwise +* +* N (input) INTEGER +* The order of the block reflector H. N >= 0. +* +* K (input) INTEGER +* The order of the triangular factor T (= the number of +* elementary reflectors). K >= 1. +* +* V (input/output) DOUBLE PRECISION array, dimension +* (LDV,K) if STOREV = 'C' +* (LDV,N) if STOREV = 'R' +* The matrix V. See further details. +* +* LDV (input) INTEGER +* The leading dimension of the array V. +* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i). +* +* T (output) DOUBLE PRECISION array, dimension (LDT,K) +* The k by k triangular factor T of the block reflector. +* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is +* lower triangular. The rest of the array is not used. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= K. +* +* Further Details +* =============== +* +* The shape of the matrix V and the storage of the vectors which define +* the H(i) is best illustrated by the following example with n = 5 and +* k = 3. The elements equal to 1 are not stored; the corresponding +* array elements are modified but restored on exit. The rest of the +* array is not used. +* +* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +* +* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +* ( v1 1 ) ( 1 v2 v2 v2 ) +* ( v1 v2 1 ) ( 1 v3 v3 ) +* ( v1 v2 v3 ) +* ( v1 v2 v3 ) +* +* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +* +* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +* ( v1 v2 v3 ) ( v2 v2 v2 1 ) +* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +* ( 1 v3 ) +* ( 1 ) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, PREVLASTV, LASTV + DOUBLE PRECISION VII +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DTRMV +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( LSAME( DIRECT, 'F' ) ) THEN + PREVLASTV = N + DO 20 I = 1, K + PREVLASTV = MAX( I, PREVLASTV ) + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 10 J = 1, I + T( J, I ) = ZERO + 10 CONTINUE + ELSE +* +* general case +* + VII = V( I, I ) + V( I, I ) = ONE + IF( LSAME( STOREV, 'C' ) ) THEN +! Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) +* + CALL DGEMV( 'Transpose', J-I+1, I-1, -TAU( I ), + $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, + $ T( 1, I ), 1 ) + ELSE +! Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T +* + CALL DGEMV( 'No transpose', I-1, J-I+1, -TAU( I ), + $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, + $ T( 1, I ), 1 ) + END IF + V( I, I ) = VII +* +* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) +* + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, + $ LDT, T( 1, I ), 1 ) + T( I, I ) = TAU( I ) + IF( I.GT.1 ) THEN + PREVLASTV = MAX( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + 20 CONTINUE + ELSE + PREVLASTV = 1 + DO 40 I = K, 1, -1 + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 30 J = I, K + T( J, I ) = ZERO + 30 CONTINUE + ELSE +* +* general case +* + IF( I.LT.K ) THEN + IF( LSAME( STOREV, 'C' ) ) THEN + VII = V( N-K+I, I ) + V( N-K+I, I ) = ONE +! Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) := +* - tau(i) * V(j:n-k+i,i+1:k)**T * +* V(j:n-k+i,i) +* + CALL DGEMV( 'Transpose', N-K+I-J+1, K-I, -TAU( I ), + $ V( J, I+1 ), LDV, V( J, I ), 1, ZERO, + $ T( I+1, I ), 1 ) + V( N-K+I, I ) = VII + ELSE + VII = V( I, N-K+I ) + V( I, N-K+I ) = ONE +! Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) := +* - tau(i) * V(i+1:k,j:n-k+i) * +* V(i,j:n-k+i)**T +* + CALL DGEMV( 'No transpose', K-I, N-K+I-J+1, + $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, + $ ZERO, T( I+1, I ), 1 ) + V( I, N-K+I ) = VII + END IF +* +* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) +* + CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, + $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + IF( I.GT.1 ) THEN + PREVLASTV = MIN( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + T( I, I ) = TAU( I ) + END IF + 40 CONTINUE + END IF + RETURN +* +* End of DLARFT +* + END + SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, K1, K2, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DLASWP performs a series of row interchanges on the matrix A. +* One row interchange is initiated for each of rows K1 through K2 of A. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The number of columns of the matrix A. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the matrix of column dimension N to which the row +* interchanges will be applied. +* On exit, the permuted matrix. +* +* LDA (input) INTEGER +* The leading dimension of the array A. +* +* K1 (input) INTEGER +* The first element of IPIV for which a row interchange will +* be done. +* +* K2 (input) INTEGER +* The last element of IPIV for which a row interchange will +* be done. +* +* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) +* The vector of pivot indices. Only the elements in positions +* K1 through K2 of IPIV are accessed. +* IPIV(K) = L implies rows K and L are to be interchanged. +* +* INCX (input) INTEGER +* The increment between successive values of IPIV. If IPIV +* is negative, the pivots are applied in reverse order. +* +* Further Details +* =============== +* +* Modified by +* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 + DOUBLE PRECISION TEMP +* .. +* .. Executable Statements .. +* +* Interchange row I with row IPIV(I) for each of rows K1 through K2. +* + IF( INCX.GT.0 ) THEN + IX0 = K1 + I1 = K1 + I2 = K2 + INC = 1 + ELSE IF( INCX.LT.0 ) THEN + IX0 = 1 + ( 1-K2 )*INCX + I1 = K2 + I2 = K1 + INC = -1 + ELSE + RETURN + END IF +* + N32 = ( N / 32 )*32 + IF( N32.NE.0 ) THEN + DO 30 J = 1, N32, 32 + IX = IX0 + DO 20 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 10 K = J, J + 31 + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 10 CONTINUE + END IF + IX = IX + INCX + 20 CONTINUE + 30 CONTINUE + END IF + IF( N32.NE.N ) THEN + N32 = N32 + 1 + IX = IX0 + DO 50 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 40 K = N32, N + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 40 CONTINUE + END IF + IX = IX + INCX + 50 CONTINUE + END IF +* + RETURN +* +* End of DLASWP +* + END + SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORM2R overwrites the general real m by n matrix C with +* +* Q * C if SIDE = 'L' and TRANS = 'N', or +* +* Q**T* C if SIDE = 'L' and TRANS = 'T', or +* +* C * Q if SIDE = 'R' and TRANS = 'N', or +* +* C * Q**T if SIDE = 'R' and TRANS = 'T', +* +* where Q is a real orthogonal matrix defined as the product of k +* elementary reflectors +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n +* if SIDE = 'R'. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply Q or Q**T from the Left +* = 'R': apply Q or Q**T from the Right +* +* TRANS (input) CHARACTER*1 +* = 'N': apply Q (No transpose) +* = 'T': apply Q**T (Transpose) +* +* M (input) INTEGER +* The number of rows of the matrix C. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix C. N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines +* the matrix Q. +* If SIDE = 'L', M >= K >= 0; +* if SIDE = 'R', N >= K >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,K) +* The i-th column must contain the vector which defines the +* elementary reflector H(i), for i = 1,2,...,k, as returned by +* DGEQRF in the first k columns of its array argument A. +* A is modified by the routine but restored on exit. +* +* LDA (input) INTEGER +* The leading dimension of the array A. +* If SIDE = 'L', LDA >= max(1,M); +* if SIDE = 'R', LDA >= max(1,N). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DGEQRF. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m by n matrix C. +* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension +* (N) if SIDE = 'L', +* (M) if SIDE = 'R' +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + DOUBLE PRECISION AII +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORM2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) + $ THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), + $ LDC, WORK ) + A( I, I ) = AII + 10 CONTINUE + RETURN +* +* End of DORM2R +* + END + SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORMQR overwrites the general real M-by-N matrix C with +* +* SIDE = 'L' SIDE = 'R' +* TRANS = 'N': Q * C C * Q +* TRANS = 'T': Q**T * C C * Q**T +* +* where Q is a real orthogonal matrix defined as the product of k +* elementary reflectors +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N +* if SIDE = 'R'. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply Q or Q**T from the Left; +* = 'R': apply Q or Q**T from the Right. +* +* TRANS (input) CHARACTER*1 +* = 'N': No transpose, apply Q; +* = 'T': Transpose, apply Q**T. +* +* M (input) INTEGER +* The number of rows of the matrix C. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix C. N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines +* the matrix Q. +* If SIDE = 'L', M >= K >= 0; +* if SIDE = 'R', N >= K >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,K) +* The i-th column must contain the vector which defines the +* elementary reflector H(i), for i = 1,2,...,k, as returned by +* DGEQRF in the first k columns of its array argument A. +* A is modified by the routine but restored on exit. +* +* LDA (input) INTEGER +* The leading dimension of the array A. +* If SIDE = 'L', LDA >= max(1,M); +* if SIDE = 'R', LDA >= max(1,N). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DGEQRF. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the M-by-N matrix C. +* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension +* (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. +* If SIDE = 'L', LWORK >= max(1,N); +* if SIDE = 'R', LWORK >= max(1,M). +* For optimum performance LWORK >= N*NB if SIDE = 'L', and +* LWORK >= M*NB if SIDE = 'R', where NB is the optimal +* blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + DOUBLE PRECISION T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. NB may be at most NBMAX, where NBMAX +* is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), + $ LDA, TAU( I ), T, LDT ) + IF( LEFT ) THEN +* +* H or H**T is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H or H**T is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H or H**T +* + CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, + $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, + $ WORK, LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMQR +* + END + DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* -- LAPACK auxiliary routine (version 3.3.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* Based on LAPACK DLAMCH but with Fortran 95 query functions +* See: http://www.cs.utk.edu/~luszczek/lapack/lamch.html +* and +* http://www.netlib.org/lapack-dev/lapack-coding/program-style.html#id2537289 +* July 2010 +* +* .. Scalar Arguments .. + CHARACTER CMACH +* .. +* +* Purpose +* ======= +* +* DLAMCH determines double precision machine parameters. +* +* Arguments +* ========= +* +* CMACH (input) CHARACTER*1 +* Specifies the value to be returned by DLAMCH: +* = 'E' or 'e', DLAMCH := eps +* = 'S' or 's , DLAMCH := sfmin +* = 'B' or 'b', DLAMCH := base +* = 'P' or 'p', DLAMCH := eps*base +* = 'N' or 'n', DLAMCH := t +* = 'R' or 'r', DLAMCH := rnd +* = 'M' or 'm', DLAMCH := emin +* = 'U' or 'u', DLAMCH := rmin +* = 'L' or 'l', DLAMCH := emax +* = 'O' or 'o', DLAMCH := rmax +* +* where +* +* eps = relative machine precision +* sfmin = safe minimum, such that 1/sfmin does not overflow +* base = base of the machine +* prec = eps*base +* t = number of (base) digits in the mantissa +* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise +* emin = minimum exponent before (gradual) underflow +* rmin = underflow threshold - base**(emin-1) +* emax = largest exponent before overflow +* rmax = overflow threshold - (base**emax)*(1-eps) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, + $ MINEXPONENT, RADIX, TINY +* .. +* .. Executable Statements .. +* +* +* Assume rounding, not chopping. Always. +* + RND = ONE +* + IF( ONE.EQ.RND ) THEN + EPS = EPSILON(ZERO) * 0.5 + ELSE + EPS = EPSILON(ZERO) + END IF +* + IF( LSAME( CMACH, 'E' ) ) THEN + RMACH = EPS + ELSE IF( LSAME( CMACH, 'S' ) ) THEN + SFMIN = TINY(ZERO) + SMALL = ONE / HUGE(ZERO) + IF( SMALL.GE.SFMIN ) THEN +* +* Use SMALL plus a bit, to avoid the possibility of rounding +* causing overflow when computing 1/sfmin. +* + SFMIN = SMALL*( ONE+EPS ) + END IF + RMACH = SFMIN + ELSE IF( LSAME( CMACH, 'B' ) ) THEN + RMACH = RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'P' ) ) THEN + RMACH = EPS * RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'N' ) ) THEN + RMACH = DIGITS(ZERO) + ELSE IF( LSAME( CMACH, 'R' ) ) THEN + RMACH = RND + ELSE IF( LSAME( CMACH, 'M' ) ) THEN + RMACH = MINEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'U' ) ) THEN + RMACH = tiny(zero) + ELSE IF( LSAME( CMACH, 'L' ) ) THEN + RMACH = MAXEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'O' ) ) THEN + RMACH = HUGE(ZERO) + ELSE + RMACH = ZERO + END IF +* + DLAMCH = RMACH + RETURN +* +* End of DLAMCH +* + END +************************************************************************ +* + INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER ISPEC + REAL ONE, ZERO +* .. +* +* Purpose +* ======= +* +* IEEECK is called from the ILAENV to verify that Infinity and +* possibly NaN arithmetic is safe (i.e. will not trap). +* +* Arguments +* ========= +* +* ISPEC (input) INTEGER +* Specifies whether to test just for inifinity arithmetic +* or whether to test for infinity and NaN arithmetic. +* = 0: Verify infinity arithmetic only. +* = 1: Verify infinity and NaN arithmetic. +* +* ZERO (input) REAL +* Must contain the value 0.0 +* This is passed to prevent the compiler from optimizing +* away this code. +* +* ONE (input) REAL +* Must contain the value 1.0 +* This is passed to prevent the compiler from optimizing +* away this code. +* +* RETURN VALUE: INTEGER +* = 0: Arithmetic failed to produce the correct answers +* = 1: Arithmetic produced the correct answers +* +* ===================================================================== +* +* .. Local Scalars .. + REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, + $ NEGZRO, NEWZRO, POSINF +* .. +* .. Executable Statements .. + IEEECK = 1 +* + POSINF = ONE / ZERO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = -ONE / ZERO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGZRO = ONE / ( NEGINF+ONE ) + IF( NEGZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = ONE / NEGZRO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEWZRO = NEGZRO + ZERO + IF( NEWZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = ONE / NEWZRO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = NEGINF*POSINF + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = POSINF*POSINF + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* +* +* +* +* Return if we were only asked to check infinity arithmetic +* + IF( ISPEC.EQ.0 ) + $ RETURN +* + NAN1 = POSINF + NEGINF +* + NAN2 = POSINF / NEGINF +* + NAN3 = POSINF / POSINF +* + NAN4 = POSINF*ZERO +* + NAN5 = NEGINF*NEGZRO +* + NAN6 = NAN5*ZERO +* + IF( NAN1.EQ.NAN1 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN2.EQ.NAN2 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN3.EQ.NAN3 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN4.EQ.NAN4 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN5.EQ.NAN5 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN6.EQ.NAN6 ) THEN + IEEECK = 0 + RETURN + END IF +* + RETURN + END + INTEGER FUNCTION ILADLC( M, N, A, LDA ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.2.2) -- +* +* -- June 2010 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* ILADLC scans A for its last non-zero column. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. +* +* N (input) INTEGER +* The number of columns of the matrix A. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The m by n matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( N.EQ.0 ) THEN + ILADLC = N + ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILADLC = N + ELSE +* Now scan each column from the end, returning with the first +* non-zero. + DO ILADLC = N, 1, -1 + DO I = 1, M + IF( A(I, ILADLC).NE.ZERO ) RETURN + END DO + END DO + END IF + RETURN + END + INTEGER FUNCTION ILADLR( M, N, A, LDA ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* ILADLR scans A for its last non-zero row. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. +* +* N (input) INTEGER +* The number of columns of the matrix A. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The m by n matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( M.EQ.0 ) THEN + ILADLR = M + ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILADLR = M + ELSE +* Scan up each column tracking the last zero row seen. + ILADLR = 0 + DO J = 1, N + I=M + DO WHILE ((A(I,J).NE.ZERO).AND.(I.GE.1)) + I=I-1 + ENDDO + ILADLR = MAX( ILADLR, I ) + END DO + END IF + RETURN + END + INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* -- LAPACK auxiliary routine (version 3.2.1) -- +* +* -- April 2009 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* Purpose +* ======= +* +* ILAENV is called from the LAPACK routines to choose problem-dependent +* parameters for the local environment. See ISPEC for a description of +* the parameters. +* +* ILAENV returns an INTEGER +* if ILAENV >= 0: ILAENV returns the value of the parameter specified +* by ISPEC +* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal +* value. +* +* This version provides a set of parameters which should give good, +* but not optimal, performance on many of the currently available +* computers. Users are encouraged to modify this subroutine to set +* the tuning parameters for their particular machine using the option +* and problem size information in the arguments. +* +* This routine will not function correctly if it is converted to all +* lower case. Converting it to all upper case is allowed. +* +* Arguments +* ========= +* +* ISPEC (input) INTEGER +* Specifies the parameter to be returned as the value of +* ILAENV. +* = 1: the optimal blocksize; if this value is 1, an unblocked +* algorithm will give the best performance. +* = 2: the minimum block size for which the block routine +* should be used; if the usable block size is less than +* this value, an unblocked routine should be used. +* = 3: the crossover point (in a block routine, for N less +* than this value, an unblocked routine should be used) +* = 4: the number of shifts, used in the nonsymmetric +* eigenvalue routines (DEPRECATED) +* = 5: the minimum column dimension for blocking to be used; +* rectangular blocks must have dimension at least k by m, +* where k is given by ILAENV(2,...) and m by ILAENV(5,...) +* = 6: the crossover point for the SVD (when reducing an m by n +* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds +* this value, a QR factorization is used first to reduce +* the matrix to a triangular form.) +* = 7: the number of processors +* = 8: the crossover point for the multishift QR method +* for nonsymmetric eigenvalue problems (DEPRECATED) +* = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* =10: ieee NaN arithmetic can be trusted not to trap +* =11: infinity arithmetic can be trusted not to trap +* 12 <= ISPEC <= 16: +* xHSEQR or one of its subroutines, +* see IPARMQ for detailed explanation +* +* NAME (input) CHARACTER*(*) +* The name of the calling subroutine, in either upper case or +* lower case. +* +* OPTS (input) CHARACTER*(*) +* The character options to the subroutine NAME, concatenated +* into a single character string. For example, UPLO = 'U', +* TRANS = 'T', and DIAG = 'N' for a triangular routine would +* be specified as OPTS = 'UTN'. +* +* N1 (input) INTEGER +* N2 (input) INTEGER +* N3 (input) INTEGER +* N4 (input) INTEGER +* Problem dimensions for the subroutine NAME; these may not all +* be required. +* +* Further Details +* =============== +* +* The following conventions have been used when calling ILAENV from the +* LAPACK routines: +* 1) OPTS is a concatenation of all of the character options to +* subroutine NAME, in the same order that they appear in the +* argument list for NAME, even if they are not used in determining +* the value of the parameter specified by ISPEC. +* 2) The problem dimensions N1, N2, N3, N4 are specified in the order +* that they appear in the argument list for NAME. N1 is used +* first, N2 second, and so on, and unused problem dimensions are +* passed a value of -1. +* 3) The parameter value returned by ILAENV is checked for validity in +* the calling subroutine. For example, ILAENV is used to retrieve +* the optimal blocksize for STRTRI as follows: +* +* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) +* IF( NB.LE.1 ) NB = MAX( 1, N ) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IC, IZ, NB, NBMIN, NX + LOGICAL CNAME, SNAME + CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 +* .. +* .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, INT, MIN, REAL +* .. +* .. External Functions .. + INTEGER IEEECK, IPARMQ + EXTERNAL IEEECK, IPARMQ +* .. +* .. Executable Statements .. +* + GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, + $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC +* +* Invalid value for ISPEC +* + ILAENV = -1 + RETURN +* + 10 CONTINUE +* +* Convert NAME to upper case if the first character is lower case. +* + ILAENV = 1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 20 CONTINUE + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + 30 CONTINUE + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 40 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 40 CONTINUE + END IF + END IF +* + C1 = SUBNAM( 1: 1 ) + SNAME = C1.EQ.'S' .OR. C1.EQ.'D' + CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' + IF( .NOT.( CNAME .OR. SNAME ) ) + $ RETURN + C2 = SUBNAM( 2: 3 ) + C3 = SUBNAM( 4: 6 ) + C4 = C3( 2: 3 ) +* + GO TO ( 50, 60, 70 )ISPEC +* + 50 CONTINUE +* +* ISPEC = 1: block size +* +* In these examples, separate code is provided for setting NB for +* real and complex. We assume that NB will take the same value in +* single or double precision. +* + NB = 1 +* + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'PO' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRF' ) THEN + NB = 64 + ELSE IF( C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( C2.EQ.'GB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'PB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'TR' ) THEN + IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'LA' ) THEN + IF( C3.EQ.'UUM' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN + IF( C3.EQ.'EBZ' ) THEN + NB = 1 + END IF + END IF + ILAENV = NB + RETURN +* + 60 CONTINUE +* +* ISPEC = 2: minimum block size +* + NBMIN = 2 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NBMIN = 8 + ELSE + NBMIN = 8 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + END IF + ILAENV = NBMIN + RETURN +* + 70 CONTINUE +* +* ISPEC = 3: crossover point +* + NX = 0 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + END IF + ILAENV = NX + RETURN +* + 80 CONTINUE +* +* ISPEC = 4: number of shifts (used by xHSEQR) +* + ILAENV = 6 + RETURN +* + 90 CONTINUE +* +* ISPEC = 5: minimum column dimension (not used) +* + ILAENV = 2 + RETURN +* + 100 CONTINUE +* +* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) +* + ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) + RETURN +* + 110 CONTINUE +* +* ISPEC = 7: number of processors (not used) +* + ILAENV = 1 + RETURN +* + 120 CONTINUE +* +* ISPEC = 8: crossover point for multishift (used by xHSEQR) +* + ILAENV = 50 + RETURN +* + 130 CONTINUE +* +* ISPEC = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* + ILAENV = 25 + RETURN +* + 140 CONTINUE +* +* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 1, 0.0, 1.0 ) + END IF + RETURN +* + 150 CONTINUE +* +* ISPEC = 11: infinity arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 0, 0.0, 1.0 ) + END IF + RETURN +* + 160 CONTINUE +* +* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. +* + ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + RETURN +* +* End of ILAENV +* + END + INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, ISPEC, LWORK, N + CHARACTER NAME*( * ), OPTS*( * ) +* +* Purpose +* ======= +* +* This program sets problem and machine dependent parameters +* useful for xHSEQR and its subroutines. It is called whenever +* ILAENV is called with 12 <= ISPEC <= 16 +* +* Arguments +* ========= +* +* ISPEC (input) integer scalar +* ISPEC specifies which tunable parameter IPARMQ should +* return. +* +* ISPEC=12: (INMIN) Matrices of order nmin or less +* are sent directly to xLAHQR, the implicit +* double shift QR algorithm. NMIN must be +* at least 11. +* +* ISPEC=13: (INWIN) Size of the deflation window. +* This is best set greater than or equal to +* the number of simultaneous shifts NS. +* Larger matrices benefit from larger deflation +* windows. +* +* ISPEC=14: (INIBL) Determines when to stop nibbling and +* invest in an (expensive) multi-shift QR sweep. +* If the aggressive early deflation subroutine +* finds LD converged eigenvalues from an order +* NW deflation window and LD.GT.(NW*NIBBLE)/100, +* then the next QR sweep is skipped and early +* deflation is applied immediately to the +* remaining active diagonal block. Setting +* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a +* multi-shift QR sweep whenever early deflation +* finds a converged eigenvalue. Setting +* IPARMQ(ISPEC=14) greater than or equal to 100 +* prevents TTQRE from skipping a multi-shift +* QR sweep. +* +* ISPEC=15: (NSHFTS) The number of simultaneous shifts in +* a multi-shift QR iteration. +* +* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the +* following meanings. +* 0: During the multi-shift QR sweep, +* xLAQR5 does not accumulate reflections and +* does not use matrix-matrix multiply to +* update the far-from-diagonal matrix +* entries. +* 1: During the multi-shift QR sweep, +* xLAQR5 and/or xLAQRaccumulates reflections +* and uses +* matrix-matrix multiply to update the +* far-from-diagonal matrix entries. +* 2: During the multi-shift QR sweep. +* xLAQR5 accumulates reflections and takes +* advantage of 2-by-2 block structure during +* matrix-matrix multiplies. +* (If xTRMM is slower than xGEMM, then +* IPARMQ(ISPEC=16)=1 may be more efficient than +* IPARMQ(ISPEC=16)=2 despite the greater level of +* arithmetic work implied by the latter choice.) +* +* NAME (input) character string +* Name of the calling subroutine +* +* OPTS (input) character string +* This is a concatenation of the string arguments to +* TTQRE. +* +* N (input) integer scalar +* N is the order of the Hessenberg matrix H. +* +* ILO (input) INTEGER +* IHI (input) INTEGER +* It is assumed that H is already upper triangular +* in rows and columns 1:ILO-1 and IHI+1:N. +* +* LWORK (input) integer scalar +* The amount of workspace available. +* +* Further Details +* =============== +* +* Little is known about how best to choose these parameters. +* It is possible to use different values of the parameters +* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. +* +* It is probably best to choose different parameters for +* different matrices and different parameters at different +* times during the iteration, but this has not been +* implemented --- yet. +* +* +* The best choices of most of the parameters depend +* in an ill-understood way on the relative execution +* rate of xLAQR3 and xLAQR5 and on the nature of each +* particular eigenvalue problem. Experiment may be the +* only practical way to determine which choices are most +* effective. +* +* Following is a list of default values supplied by IPARMQ. +* These defaults may be adjusted in order to attain better +* performance in any particular computational environment. +* +* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. +* Default: 75. (Must be at least 11.) +* +* IPARMQ(ISPEC=13) Recommended deflation window size. +* This depends on ILO, IHI and NS, the +* number of simultaneous shifts returned +* by IPARMQ(ISPEC=15). The default for +* (IHI-ILO+1).LE.500 is NS. The default +* for (IHI-ILO+1).GT.500 is 3*NS/2. +* +* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. +* +* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. +* a multi-shift QR iteration. +* +* If IHI-ILO+1 is ... +* +* greater than ...but less ... the +* or equal to ... than default is +* +* 0 30 NS = 2+ +* 30 60 NS = 4+ +* 60 150 NS = 10 +* 150 590 NS = ** +* 590 3000 NS = 64 +* 3000 6000 NS = 128 +* 6000 infinity NS = 256 +* +* (+) By default matrices of this order are +* passed to the implicit double shift routine +* xLAHQR. See IPARMQ(ISPEC=12) above. These +* values of NS are used only in case of a rare +* xLAHQR failure. +* +* (**) The asterisks (**) indicate an ad-hoc +* function increasing from 10 to 64. +* +* IPARMQ(ISPEC=16) Select structured matrix multiply. +* (See ISPEC=16 above for details.) +* Default: 3. +* +* ================================================================ +* .. Parameters .. + INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 + PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, + $ ISHFTS = 15, IACC22 = 16 ) + INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP + PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, + $ NIBBLE = 14, KNWSWP = 500 ) + REAL TWO + PARAMETER ( TWO = 2.0 ) +* .. +* .. Local Scalars .. + INTEGER NH, NS +* .. +* .. Intrinsic Functions .. + INTRINSIC LOG, MAX, MOD, NINT, REAL +* .. +* .. Executable Statements .. + IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. + $ ( ISPEC.EQ.IACC22 ) ) THEN +* +* ==== Set the number simultaneous shifts ==== +* + NH = IHI - ILO + 1 + NS = 2 + IF( NH.GE.30 ) + $ NS = 4 + IF( NH.GE.60 ) + $ NS = 10 + IF( NH.GE.150 ) + $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) + IF( NH.GE.590 ) + $ NS = 64 + IF( NH.GE.3000 ) + $ NS = 128 + IF( NH.GE.6000 ) + $ NS = 256 + NS = MAX( 2, NS-MOD( NS, 2 ) ) + END IF +* + IF( ISPEC.EQ.INMIN ) THEN +* +* +* ===== Matrices of order smaller than NMIN get sent +* . to xLAHQR, the classic double shift algorithm. +* . This must be at least 11. ==== +* + IPARMQ = NMIN +* + ELSE IF( ISPEC.EQ.INIBL ) THEN +* +* ==== INIBL: skip a multi-shift qr iteration and +* . whenever aggressive early deflation finds +* . at least (NIBBLE*(window size)/100) deflations. ==== +* + IPARMQ = NIBBLE +* + ELSE IF( ISPEC.EQ.ISHFTS ) THEN +* +* ==== NSHFTS: The number of simultaneous shifts ===== +* + IPARMQ = NS +* + ELSE IF( ISPEC.EQ.INWIN ) THEN +* +* ==== NW: deflation window size. ==== +* + IF( NH.LE.KNWSWP ) THEN + IPARMQ = NS + ELSE + IPARMQ = 3*NS / 2 + END IF +* + ELSE IF( ISPEC.EQ.IACC22 ) THEN +* +* ==== IACC22: Whether to accumulate reflections +* . before updating the far-from-diagonal elements +* . and whether to use 2-by-2 block structure while +* . doing it. A small amount of work could be saved +* . by making this choice dependent also upon the +* . NH=IHI-ILO+1. +* + IPARMQ = 0 + IF( NS.GE.KACMIN ) + $ IPARMQ = 1 + IF( NS.GE.K22MIN ) + $ IPARMQ = 2 +* + ELSE +* ===== invalid value of ispec ===== + IPARMQ = -1 +* + END IF +* +* ==== End of IPARMQ ==== +* + END + diff --git a/toms1012/sample_input2d.dat b/toms1012/sample_input2d.dat new file mode 100644 index 0000000..1ebeed6 --- /dev/null +++ b/toms1012/sample_input2d.dat @@ -0,0 +1,188 @@ +2,43,101,1 +-0.737779900597,-0.675041345605 +-0.737779900597,0.587602108436 +0.524863553445,-0.675041345605 +0.524863553445,0.587602108436 +-0.663506756241,0.166253571025 +-0.584282068929,-0.394609706728 +-0.584282068929,0.446685209901 +-0.584282068929,0.586901029339 +-0.425832694304,-0.534825526166 +-0.425832694304,-0.464717616447 +-0.425832694304,-0.184285977571 +-0.425832694304,-0.0440701581327 +-0.425832694304,0.0961456613055 +-0.425832694304,0.236361480744 +-0.425832694304,0.51679311962 +-0.108933945055,-0.675041345605 +-0.108933945055,-0.534825526166 +-0.108933945055,-0.464717616447 +-0.108933945055,-0.394609706728 +-0.108933945055,-0.25439388729 +-0.108933945055,-0.184285977571 +-0.108933945055,-0.114178067852 +-0.108933945055,-0.0440701581327 +-0.108933945055,0.0961456613055 +-0.108933945055,0.166253571025 +-0.108933945055,0.236361480744 +-0.108933945055,0.376577300182 +-0.108933945055,0.51679311962 +-0.108933945055,0.587602108436 +0.524863553445,-0.534825526166 +0.524863553445,-0.464717616447 +0.524863553445,-0.394609706728 +0.524863553445,-0.25439388729 +0.524863553445,-0.184285977571 +0.524863553445,-0.114178067852 +0.524863553445,-0.0440701581327 +0.524863553445,0.0961456613055 +0.524863553445,0.166253571025 +0.524863553445,0.236361480744 +0.524863553445,0.376577300182 +0.524863553445,0.446685209901 +0.524863553445,0.51679311962 +0.524863553445,0.586901029339 +296835782027 +736030395045 +1.06918217819E+016 +3.20566930178E+016 +73374496803300 +189039708822000 +273719385634000 +326069037783000 +675040018268000 +756967336463000 +914266006037000 +1.0830311159E+015 +1218388638980000 +1326756634210000 +1463454444460000 +2.5144413074E+015 +2.77933373432E+015 +2836545644680000 +3155262430390000 +3451182362430000 +3715001247780000 +3896447879110000 +4.11531577031E+015 +4745519778190000 +4840384897050000 +5228331120200000 +5481722046370000 +6250890553900000 +7367804014150000 +1.16388102101E+016 +1.11174656608E+016 +1.25221884669E+016 +1.49468718462E+016 +1.468022513E+016 +1.54642127154E+016 +1.65072763423E+016 +2.08248675151E+016 +1.86574133761E+016 +2.01386128979E+016 +2.38441779462E+016 +2.52856646169E+016 +2.56482815535E+016 +2.78334409382E+016 +-0.737779900597,-0.534825526166 +-0.737779900597,-0.464717616447 +-0.737779900597,-0.394609706728 +-0.737779900597,-0.25439388729 +-0.737779900597,-0.184285977571 +-0.737779900597,-0.114178067852 +-0.737779900597,-0.0440701581327 +-0.737779900597,0.0961456613055 +-0.737779900597,0.166253571025 +-0.737779900597,0.236361480744 +-0.737779900597,0.376577300182 +-0.737779900597,0.446685209901 +-0.737779900597,0.51679311962 +-0.737779900597,0.586901029339 +-0.73282835764,-0.675041345605 +-0.73282835764,-0.534825526166 +-0.73282835764,-0.464717616447 +-0.73282835764,-0.394609706728 +-0.73282835764,-0.25439388729 +-0.73282835764,-0.184285977571 +-0.73282835764,-0.114178067852 +-0.73282835764,-0.0440701581327 +-0.73282835764,0.0961456613055 +-0.73282835764,0.166253571025 +-0.73282835764,0.236361480744 +-0.73282835764,0.376577300182 +-0.73282835764,0.446685209901 +-0.73282835764,0.51679311962 +-0.73282835764,0.586901029339 +-0.73282835764,0.587602108436 +-0.722925271725,-0.675041345605 +-0.722925271725,-0.534825526166 +-0.722925271725,-0.464717616447 +-0.722925271725,-0.394609706728 +-0.722925271725,-0.25439388729 +-0.722925271725,-0.184285977571 +-0.722925271725,-0.114178067852 +-0.722925271725,-0.0440701581327 +-0.722925271725,0.0961456613055 +-0.722925271725,0.166253571025 +-0.722925271725,0.236361480744 +-0.722925271725,0.376577300182 +-0.722925271725,0.446685209901 +-0.722925271725,0.51679311962 +-0.722925271725,0.586901029339 +-0.722925271725,0.587602108436 +-0.703119099897,-0.675041345605 +-0.703119099897,-0.534825526166 +-0.703119099897,-0.464717616447 +-0.703119099897,-0.394609706728 +-0.703119099897,-0.25439388729 +-0.703119099897,-0.184285977571 +-0.703119099897,-0.114178067852 +-0.703119099897,-0.0440701581327 +-0.703119099897,0.0961456613055 +-0.703119099897,0.166253571025 +-0.703119099897,0.236361480744 +-0.703119099897,0.376577300182 +-0.703119099897,0.446685209901 +-0.703119099897,0.51679311962 +-0.703119099897,0.586901029339 +-0.703119099897,0.587602108436 +-0.663506756241,-0.675041345605 +-0.663506756241,-0.534825526166 +-0.663506756241,-0.464717616447 +-0.663506756241,-0.394609706728 +-0.663506756241,-0.25439388729 +-0.663506756241,-0.184285977571 +-0.663506756241,-0.114178067852 +-0.663506756241,-0.0440701581327 +-0.663506756241,0.0961456613055 +-0.663506756241,0.236361480744 +-0.663506756241,0.376577300182 +-0.663506756241,0.446685209901 +-0.663506756241,0.51679311962 +-0.663506756241,0.586901029339 +-0.663506756241,0.587602108436 +-0.584282068929,-0.675041345605 +-0.584282068929,-0.534825526166 +-0.584282068929,-0.464717616447 +-0.584282068929,-0.25439388729 +-0.584282068929,-0.184285977571 +-0.584282068929,-0.114178067852 +-0.584282068929,-0.0440701581327 +-0.584282068929,0.0961456613055 +-0.584282068929,0.166253571025 +-0.584282068929,0.236361480744 +-0.584282068929,0.376577300182 +-0.584282068929,0.51679311962 +-0.584282068929,0.587602108436 +-0.425832694304,-0.675041345605 +-0.425832694304,-0.394609706728 +-0.425832694304,-0.25439388729 +-0.425832694304,-0.114178067852 +-0.425832694304,0.166253571025 +-0.425832694304,0.376577300182 +-0.425832694304,0.446685209901 +-0.425832694304,0.586901029339 +-0.425832694304,0.587602108436 +-0.108933945055,0.446685209901 +-0.108933945055,0.586901029339 diff --git a/toms1012/sample_input4d.dat b/toms1012/sample_input4d.dat new file mode 100644 index 0000000..f786eda --- /dev/null +++ b/toms1012/sample_input4d.dat @@ -0,0 +1,1297 @@ +4,432,432,1 +-0.429559544383,-0.141336559823,-0.324322498044,-0.452914378473 +-0.429559544383,-0.141336559823,-0.324322498044,0.346266169217 +-0.429559544383,-0.141336559823,0.474858049646,-0.452914378473 +-0.429559544383,-0.141336559823,0.474858049646,0.346266169217 +0.369621003307,-0.141336559823,-0.324322498044,-0.452914378473 +0.369621003307,-0.141336559823,-0.324322498044,0.346266169217 +0.369621003307,-0.141336559823,0.474858049646,-0.452914378473 +0.369621003307,-0.141336559823,0.474858049646,0.346266169217 +0.369621003307,0.657843987867,-0.324322498044,-0.452914378473 +0.369621003307,0.657843987867,-0.324322498044,0.346266169217 +0.369621003307,0.657843987867,0.474858049646,-0.452914378473 +0.369621003307,0.657843987867,0.474858049646,0.346266169217 +-0.429559544383,-0.141336559823,-0.302384208499,-0.452914378473 +-0.429559544383,-0.141336559823,-0.302384208499,0.21269962571 +-0.429559544383,-0.141336559823,-0.277311877591,-0.452914378473 +-0.429559544383,-0.141336559823,-0.277311877591,-0.364165844582 +-0.429559544383,-0.141336559823,-0.277311877591,-0.275417310691 +-0.429559544383,-0.141336559823,-0.277311877591,0.0795768248736 +-0.429559544383,-0.141336559823,-0.277311877591,0.123951091819 +-0.429559544383,-0.141336559823,-0.277311877591,0.21269962571 +-0.429559544383,-0.141336559823,-0.277311877591,0.345822426547 +-0.429559544383,-0.141336559823,-0.277311877591,0.346266169217 +-0.429559544383,-0.141336559823,-0.227167215775,-0.1866687768 +-0.429559544383,-0.141336559823,-0.227167215775,-0.142294509854 +-0.429559544383,-0.141336559823,-0.227167215775,-0.0979202429087 +-0.429559544383,-0.141336559823,-0.227167215775,-0.0535459759631 +-0.429559544383,-0.141336559823,-0.227167215775,0.0352025579281 +-0.429559544383,-0.141336559823,-0.227167215775,0.0795768248736 +-0.429559544383,-0.141336559823,-0.227167215775,0.123951091819 +-0.429559544383,-0.141336559823,-0.227167215775,0.21269962571 +-0.429559544383,-0.141336559823,-0.227167215775,0.257073892656 +-0.429559544383,-0.141336559823,-0.227167215775,0.301448159602 +-0.429559544383,-0.141336559823,-0.227167215775,0.345822426547 +-0.429559544383,-0.141336559823,-0.227167215775,0.346266169217 +-0.429559544383,-0.141336559823,-0.126877892144,-0.364165844582 +-0.429559544383,-0.141336559823,-0.126877892144,-0.319791577637 +-0.429559544383,-0.141336559823,-0.126877892144,-0.275417310691 +-0.429559544383,-0.141336559823,-0.126877892144,-0.1866687768 +-0.429559544383,-0.141336559823,-0.126877892144,-0.142294509854 +-0.429559544383,-0.141336559823,-0.126877892144,-0.0979202429087 +-0.429559544383,-0.141336559823,-0.126877892144,-0.0535459759631 +-0.429559544383,-0.141336559823,-0.126877892144,0.0352025579281 +-0.429559544383,-0.141336559823,-0.126877892144,0.0795768248736 +-0.429559544383,-0.141336559823,-0.126877892144,0.123951091819 +-0.429559544383,-0.141336559823,-0.126877892144,0.21269962571 +-0.429559544383,-0.141336559823,-0.126877892144,0.257073892656 +-0.429559544383,-0.141336559823,-0.126877892144,0.301448159602 +-0.429559544383,-0.141336559823,-0.126877892144,0.345822426547 +-0.429559544383,-0.141336559823,-0.126877892144,0.346266169217 +-0.429559544383,-0.141336559823,0.0737007551197,-0.452914378473 +-0.429559544383,-0.141336559823,0.0737007551197,-0.364165844582 +-0.429559544383,-0.141336559823,0.0737007551197,-0.319791577637 +-0.429559544383,-0.141336559823,0.0737007551197,-0.275417310691 +-0.429559544383,-0.141336559823,0.0737007551197,-0.1866687768 +-0.429559544383,-0.141336559823,0.0737007551197,-0.142294509854 +-0.429559544383,-0.141336559823,0.0737007551197,-0.0979202429087 +-0.429559544383,-0.141336559823,0.0737007551197,-0.0535459759631 +-0.429559544383,-0.141336559823,0.0737007551197,0.0352025579281 +-0.429559544383,-0.141336559823,0.0737007551197,0.0795768248736 +-0.429559544383,-0.141336559823,0.0737007551197,0.123951091819 +-0.429559544383,-0.141336559823,0.0737007551197,0.21269962571 +-0.429559544383,-0.141336559823,0.0737007551197,0.257073892656 +-0.429559544383,-0.141336559823,0.0737007551197,0.301448159602 +-0.429559544383,-0.141336559823,0.0737007551197,0.345822426547 +-0.429559544383,-0.141336559823,0.0737007551197,0.346266169217 +-0.429559544383,-0.141336559823,0.474858049646,-0.364165844582 +-0.429559544383,-0.141336559823,0.474858049646,-0.319791577637 +-0.429559544383,-0.141336559823,0.474858049646,-0.275417310691 +-0.429559544383,-0.141336559823,0.474858049646,-0.1866687768 +-0.429559544383,-0.141336559823,0.474858049646,-0.142294509854 +-0.429559544383,-0.141336559823,0.474858049646,-0.0979202429087 +-0.429559544383,-0.141336559823,0.474858049646,-0.0535459759631 +-0.429559544383,-0.141336559823,0.474858049646,0.0352025579281 +-0.429559544383,-0.141336559823,0.474858049646,0.0795768248736 +-0.429559544383,-0.141336559823,0.474858049646,0.123951091819 +-0.429559544383,-0.141336559823,0.474858049646,0.21269962571 +-0.429559544383,-0.141336559823,0.474858049646,0.257073892656 +-0.429559544383,-0.141336559823,0.474858049646,0.301448159602 +-0.429559544383,-0.141336559823,0.474858049646,0.345822426547 +-0.269723434845,-0.141336559823,-0.32118845668,0.21269962571 +-0.269723434845,-0.141336559823,-0.314920373953,0.0352025579281 +-0.269723434845,-0.141336559823,-0.314920373953,0.0795768248736 +-0.269723434845,-0.141336559823,-0.314920373953,0.301448159602 +-0.269723434845,-0.141336559823,-0.302384208499,-0.364165844582 +-0.269723434845,-0.141336559823,-0.302384208499,-0.275417310691 +-0.269723434845,-0.141336559823,-0.302384208499,-0.1866687768 +-0.269723434845,-0.141336559823,-0.302384208499,-0.0979202429087 +-0.269723434845,-0.141336559823,-0.302384208499,0.0795768248736 +-0.269723434845,-0.141336559823,-0.302384208499,0.301448159602 +-0.269723434845,-0.141336559823,-0.277311877591,-0.452914378473 +-0.269723434845,-0.141336559823,-0.277311877591,-0.275417310691 +-0.269723434845,-0.141336559823,-0.277311877591,-0.142294509854 +-0.269723434845,-0.141336559823,-0.277311877591,-0.0979202429087 +-0.269723434845,-0.141336559823,-0.277311877591,0.0352025579281 +-0.269723434845,-0.141336559823,-0.277311877591,0.0795768248736 +-0.269723434845,-0.141336559823,-0.277311877591,0.123951091819 +-0.269723434845,-0.141336559823,-0.277311877591,0.21269962571 +-0.269723434845,-0.141336559823,-0.277311877591,0.257073892656 +-0.269723434845,-0.141336559823,-0.277311877591,0.345822426547 +-0.269723434845,-0.141336559823,-0.277311877591,0.346266169217 +-0.269723434845,-0.141336559823,-0.227167215775,-0.452914378473 +-0.269723434845,-0.141336559823,-0.227167215775,-0.364165844582 +-0.269723434845,-0.141336559823,-0.227167215775,-0.319791577637 +-0.269723434845,-0.141336559823,-0.227167215775,-0.275417310691 +-0.269723434845,-0.141336559823,-0.227167215775,-0.0979202429087 +-0.269723434845,-0.141336559823,-0.227167215775,-0.0535459759631 +-0.269723434845,-0.141336559823,-0.227167215775,0.0352025579281 +-0.269723434845,-0.141336559823,-0.227167215775,0.0795768248736 +-0.269723434845,-0.141336559823,-0.227167215775,0.123951091819 +-0.269723434845,-0.141336559823,-0.227167215775,0.21269962571 +-0.269723434845,-0.141336559823,-0.227167215775,0.257073892656 +-0.269723434845,-0.141336559823,-0.227167215775,0.301448159602 +-0.269723434845,-0.141336559823,-0.227167215775,0.345822426547 +-0.269723434845,-0.141336559823,-0.227167215775,0.346266169217 +-0.269723434845,-0.141336559823,-0.126877892144,-0.452914378473 +-0.269723434845,-0.141336559823,-0.126877892144,-0.364165844582 +-0.269723434845,-0.141336559823,-0.126877892144,-0.319791577637 +-0.269723434845,-0.141336559823,-0.126877892144,-0.275417310691 +-0.269723434845,-0.141336559823,-0.126877892144,-0.1866687768 +-0.269723434845,-0.141336559823,-0.126877892144,-0.142294509854 +-0.269723434845,-0.141336559823,-0.126877892144,-0.0979202429087 +-0.269723434845,-0.141336559823,-0.126877892144,-0.0535459759631 +-0.269723434845,-0.141336559823,-0.126877892144,0.0352025579281 +-0.269723434845,-0.141336559823,-0.126877892144,0.0795768248736 +-0.269723434845,-0.141336559823,-0.126877892144,0.123951091819 +-0.269723434845,-0.141336559823,-0.126877892144,0.21269962571 +-0.269723434845,-0.141336559823,-0.126877892144,0.257073892656 +-0.269723434845,-0.141336559823,-0.126877892144,0.301448159602 +-0.269723434845,-0.141336559823,-0.126877892144,0.345822426547 +-0.269723434845,-0.141336559823,-0.126877892144,0.346266169217 +-0.269723434845,-0.141336559823,0.0737007551197,-0.452914378473 +-0.269723434845,-0.141336559823,0.0737007551197,-0.364165844582 +-0.269723434845,-0.141336559823,0.0737007551197,-0.319791577637 +-0.269723434845,-0.141336559823,0.0737007551197,-0.275417310691 +-0.269723434845,-0.141336559823,0.0737007551197,-0.1866687768 +-0.269723434845,-0.141336559823,0.0737007551197,-0.142294509854 +-0.269723434845,-0.141336559823,0.0737007551197,-0.0979202429087 +-0.269723434845,-0.141336559823,0.0737007551197,-0.0535459759631 +-0.269723434845,-0.141336559823,0.0737007551197,0.0352025579281 +-0.269723434845,-0.141336559823,0.0737007551197,0.0795768248736 +-0.269723434845,-0.141336559823,0.0737007551197,0.123951091819 +-0.269723434845,-0.141336559823,0.0737007551197,0.21269962571 +-0.269723434845,-0.141336559823,0.0737007551197,0.257073892656 +-0.269723434845,-0.141336559823,0.0737007551197,0.301448159602 +-0.269723434845,-0.141336559823,0.0737007551197,0.345822426547 +-0.269723434845,-0.141336559823,0.0737007551197,0.346266169217 +-0.269723434845,-0.141336559823,0.474858049646,-0.452914378473 +-0.269723434845,-0.141336559823,0.474858049646,-0.364165844582 +-0.269723434845,-0.141336559823,0.474858049646,-0.319791577637 +-0.269723434845,-0.141336559823,0.474858049646,-0.275417310691 +-0.269723434845,-0.141336559823,0.474858049646,-0.1866687768 +-0.269723434845,-0.141336559823,0.474858049646,-0.142294509854 +-0.269723434845,-0.141336559823,0.474858049646,-0.0979202429087 +-0.269723434845,-0.141336559823,0.474858049646,-0.0535459759631 +-0.269723434845,-0.141336559823,0.474858049646,0.0352025579281 +-0.269723434845,-0.141336559823,0.474858049646,0.0795768248736 +-0.269723434845,-0.141336559823,0.474858049646,0.123951091819 +-0.269723434845,-0.141336559823,0.474858049646,0.21269962571 +-0.269723434845,-0.141336559823,0.474858049646,0.257073892656 +-0.269723434845,-0.141336559823,0.474858049646,0.301448159602 +-0.269723434845,-0.141336559823,0.474858049646,0.345822426547 +-0.269723434845,-0.141336559823,0.474858049646,0.346266169217 +-0.269723434845,0.018499549715,-0.324322498044,-0.452914378473 +-0.269723434845,0.018499549715,-0.314920373953,0.0795768248736 +-0.269723434845,0.018499549715,-0.314920373953,0.301448159602 +-0.269723434845,0.018499549715,-0.314920373953,0.346266169217 +-0.269723434845,0.018499549715,-0.302384208499,-0.452914378473 +-0.269723434845,0.018499549715,-0.302384208499,0.0795768248736 +-0.269723434845,0.018499549715,-0.302384208499,0.21269962571 +-0.269723434845,0.018499549715,-0.302384208499,0.345822426547 +-0.269723434845,0.018499549715,-0.277311877591,-0.452914378473 +-0.269723434845,0.018499549715,-0.277311877591,-0.364165844582 +-0.269723434845,0.018499549715,-0.277311877591,-0.275417310691 +-0.269723434845,0.018499549715,-0.277311877591,-0.0979202429087 +-0.269723434845,0.018499549715,-0.277311877591,0.0795768248736 +-0.269723434845,0.018499549715,-0.277311877591,0.123951091819 +-0.269723434845,0.018499549715,-0.277311877591,0.21269962571 +-0.269723434845,0.018499549715,-0.277311877591,0.301448159602 +-0.269723434845,0.018499549715,-0.277311877591,0.345822426547 +-0.269723434845,0.018499549715,-0.227167215775,-0.452914378473 +-0.269723434845,0.018499549715,-0.227167215775,-0.364165844582 +-0.269723434845,0.018499549715,-0.227167215775,-0.319791577637 +-0.269723434845,0.018499549715,-0.227167215775,-0.275417310691 +-0.269723434845,0.018499549715,-0.227167215775,-0.1866687768 +-0.269723434845,0.018499549715,-0.227167215775,-0.142294509854 +-0.269723434845,0.018499549715,-0.227167215775,-0.0979202429087 +-0.269723434845,0.018499549715,-0.227167215775,-0.0535459759631 +-0.269723434845,0.018499549715,-0.227167215775,0.0352025579281 +-0.269723434845,0.018499549715,-0.227167215775,0.0795768248736 +-0.269723434845,0.018499549715,-0.227167215775,0.257073892656 +-0.269723434845,0.018499549715,-0.227167215775,0.301448159602 +-0.269723434845,0.018499549715,-0.227167215775,0.345822426547 +-0.269723434845,0.018499549715,-0.227167215775,0.346266169217 +-0.269723434845,0.018499549715,-0.126877892144,-0.452914378473 +-0.269723434845,0.018499549715,-0.126877892144,-0.364165844582 +-0.269723434845,0.018499549715,-0.126877892144,-0.319791577637 +-0.269723434845,0.018499549715,-0.126877892144,-0.275417310691 +-0.269723434845,0.018499549715,-0.126877892144,-0.1866687768 +-0.269723434845,0.018499549715,-0.126877892144,-0.142294509854 +-0.269723434845,0.018499549715,-0.126877892144,-0.0979202429087 +-0.269723434845,0.018499549715,-0.126877892144,-0.0535459759631 +-0.269723434845,0.018499549715,-0.126877892144,0.0352025579281 +-0.269723434845,0.018499549715,-0.126877892144,0.0795768248736 +-0.269723434845,0.018499549715,-0.126877892144,0.123951091819 +-0.269723434845,0.018499549715,-0.126877892144,0.21269962571 +-0.269723434845,0.018499549715,-0.126877892144,0.257073892656 +-0.269723434845,0.018499549715,-0.126877892144,0.301448159602 +-0.269723434845,0.018499549715,-0.126877892144,0.345822426547 +-0.269723434845,0.018499549715,-0.126877892144,0.346266169217 +-0.269723434845,0.018499549715,0.0737007551197,-0.452914378473 +-0.269723434845,0.018499549715,0.0737007551197,-0.319791577637 +-0.269723434845,0.018499549715,0.0737007551197,-0.275417310691 +-0.269723434845,0.018499549715,0.0737007551197,-0.1866687768 +-0.269723434845,0.018499549715,0.0737007551197,-0.142294509854 +-0.269723434845,0.018499549715,0.0737007551197,-0.0979202429087 +-0.269723434845,0.018499549715,0.0737007551197,-0.0535459759631 +-0.269723434845,0.018499549715,0.0737007551197,0.0352025579281 +-0.269723434845,0.018499549715,0.0737007551197,0.0795768248736 +-0.269723434845,0.018499549715,0.0737007551197,0.123951091819 +-0.269723434845,0.018499549715,0.0737007551197,0.21269962571 +-0.269723434845,0.018499549715,0.0737007551197,0.257073892656 +-0.269723434845,0.018499549715,0.0737007551197,0.301448159602 +-0.269723434845,0.018499549715,0.0737007551197,0.345822426547 +-0.269723434845,0.018499549715,0.0737007551197,0.346266169217 +-0.269723434845,0.018499549715,0.474858049646,-0.452914378473 +-0.269723434845,0.018499549715,0.474858049646,-0.364165844582 +-0.269723434845,0.018499549715,0.474858049646,-0.319791577637 +-0.269723434845,0.018499549715,0.474858049646,-0.275417310691 +-0.269723434845,0.018499549715,0.474858049646,-0.1866687768 +-0.269723434845,0.018499549715,0.474858049646,-0.142294509854 +-0.269723434845,0.018499549715,0.474858049646,-0.0979202429087 +-0.269723434845,0.018499549715,0.474858049646,-0.0535459759631 +-0.269723434845,0.018499549715,0.474858049646,0.0352025579281 +-0.269723434845,0.018499549715,0.474858049646,0.0795768248736 +-0.269723434845,0.018499549715,0.474858049646,0.123951091819 +-0.269723434845,0.018499549715,0.474858049646,0.21269962571 +-0.269723434845,0.018499549715,0.474858049646,0.257073892656 +-0.269723434845,0.018499549715,0.474858049646,0.301448159602 +-0.269723434845,0.018499549715,0.474858049646,0.345822426547 +-0.269723434845,0.018499549715,0.474858049646,0.346266169217 +0.369621003307,-0.141336559823,-0.314920373953,0.257073892656 +0.369621003307,-0.141336559823,-0.302384208499,-0.1866687768 +0.369621003307,-0.141336559823,-0.302384208499,0.0352025579281 +0.369621003307,-0.141336559823,-0.302384208499,0.0795768248736 +0.369621003307,-0.141336559823,-0.302384208499,0.21269962571 +0.369621003307,-0.141336559823,-0.302384208499,0.345822426547 +0.369621003307,-0.141336559823,-0.277311877591,-0.452914378473 +0.369621003307,-0.141336559823,-0.277311877591,-0.1866687768 +0.369621003307,-0.141336559823,-0.277311877591,-0.142294509854 +0.369621003307,-0.141336559823,-0.277311877591,-0.0979202429087 +0.369621003307,-0.141336559823,-0.277311877591,-0.0535459759631 +0.369621003307,-0.141336559823,-0.277311877591,0.0352025579281 +0.369621003307,-0.141336559823,-0.277311877591,0.123951091819 +0.369621003307,-0.141336559823,-0.277311877591,0.21269962571 +0.369621003307,-0.141336559823,-0.277311877591,0.257073892656 +0.369621003307,-0.141336559823,-0.277311877591,0.301448159602 +0.369621003307,-0.141336559823,-0.277311877591,0.345822426547 +0.369621003307,-0.141336559823,-0.227167215775,-0.452914378473 +0.369621003307,-0.141336559823,-0.227167215775,-0.364165844582 +0.369621003307,-0.141336559823,-0.227167215775,-0.319791577637 +0.369621003307,-0.141336559823,-0.227167215775,-0.275417310691 +0.369621003307,-0.141336559823,-0.227167215775,-0.1866687768 +0.369621003307,-0.141336559823,-0.227167215775,-0.0979202429087 +0.369621003307,-0.141336559823,-0.227167215775,-0.0535459759631 +0.369621003307,-0.141336559823,-0.227167215775,0.0352025579281 +0.369621003307,-0.141336559823,-0.227167215775,0.0795768248736 +0.369621003307,-0.141336559823,-0.227167215775,0.123951091819 +0.369621003307,-0.141336559823,-0.227167215775,0.21269962571 +0.369621003307,-0.141336559823,-0.227167215775,0.257073892656 +0.369621003307,-0.141336559823,-0.227167215775,0.345822426547 +0.369621003307,-0.141336559823,-0.227167215775,0.346266169217 +0.369621003307,-0.141336559823,-0.126877892144,-0.452914378473 +0.369621003307,-0.141336559823,-0.126877892144,-0.364165844582 +0.369621003307,-0.141336559823,-0.126877892144,-0.319791577637 +0.369621003307,-0.141336559823,-0.126877892144,-0.275417310691 +0.369621003307,-0.141336559823,-0.126877892144,-0.1866687768 +0.369621003307,-0.141336559823,-0.126877892144,-0.142294509854 +0.369621003307,-0.141336559823,-0.126877892144,-0.0979202429087 +0.369621003307,-0.141336559823,-0.126877892144,-0.0535459759631 +0.369621003307,-0.141336559823,-0.126877892144,0.0795768248736 +0.369621003307,-0.141336559823,-0.126877892144,0.123951091819 +0.369621003307,-0.141336559823,-0.126877892144,0.21269962571 +0.369621003307,-0.141336559823,-0.126877892144,0.257073892656 +0.369621003307,-0.141336559823,-0.126877892144,0.301448159602 +0.369621003307,-0.141336559823,-0.126877892144,0.345822426547 +0.369621003307,-0.141336559823,-0.126877892144,0.346266169217 +0.369621003307,-0.141336559823,0.0737007551197,-0.452914378473 +0.369621003307,-0.141336559823,0.0737007551197,-0.364165844582 +0.369621003307,-0.141336559823,0.0737007551197,-0.319791577637 +0.369621003307,-0.141336559823,0.0737007551197,-0.275417310691 +0.369621003307,-0.141336559823,0.0737007551197,-0.1866687768 +0.369621003307,-0.141336559823,0.0737007551197,-0.142294509854 +0.369621003307,-0.141336559823,0.0737007551197,-0.0979202429087 +0.369621003307,-0.141336559823,0.0737007551197,-0.0535459759631 +0.369621003307,-0.141336559823,0.0737007551197,0.0352025579281 +0.369621003307,-0.141336559823,0.0737007551197,0.0795768248736 +0.369621003307,-0.141336559823,0.0737007551197,0.123951091819 +0.369621003307,-0.141336559823,0.0737007551197,0.21269962571 +0.369621003307,-0.141336559823,0.0737007551197,0.257073892656 +0.369621003307,-0.141336559823,0.0737007551197,0.301448159602 +0.369621003307,-0.141336559823,0.0737007551197,0.345822426547 +0.369621003307,-0.141336559823,0.0737007551197,0.346266169217 +0.369621003307,-0.141336559823,0.474858049646,-0.364165844582 +0.369621003307,-0.141336559823,0.474858049646,-0.319791577637 +0.369621003307,-0.141336559823,0.474858049646,-0.275417310691 +0.369621003307,-0.141336559823,0.474858049646,-0.1866687768 +0.369621003307,-0.141336559823,0.474858049646,-0.142294509854 +0.369621003307,-0.141336559823,0.474858049646,-0.0979202429087 +0.369621003307,-0.141336559823,0.474858049646,-0.0535459759631 +0.369621003307,-0.141336559823,0.474858049646,0.0352025579281 +0.369621003307,-0.141336559823,0.474858049646,0.0795768248736 +0.369621003307,-0.141336559823,0.474858049646,0.123951091819 +0.369621003307,-0.141336559823,0.474858049646,0.21269962571 +0.369621003307,-0.141336559823,0.474858049646,0.257073892656 +0.369621003307,-0.141336559823,0.474858049646,0.301448159602 +0.369621003307,-0.141336559823,0.474858049646,0.345822426547 +0.369621003307,0.018499549715,-0.32118845668,-0.452914378473 +0.369621003307,0.018499549715,-0.32118845668,-0.1866687768 +0.369621003307,0.018499549715,-0.314920373953,0.0795768248736 +0.369621003307,0.018499549715,-0.302384208499,-0.0535459759631 +0.369621003307,0.018499549715,-0.302384208499,0.0795768248736 +0.369621003307,0.018499549715,-0.277311877591,-0.452914378473 +0.369621003307,0.018499549715,-0.277311877591,-0.1866687768 +0.369621003307,0.018499549715,-0.277311877591,-0.142294509854 +0.369621003307,0.018499549715,-0.277311877591,-0.0979202429087 +0.369621003307,0.018499549715,-0.277311877591,0.0795768248736 +0.369621003307,0.018499549715,-0.277311877591,0.123951091819 +0.369621003307,0.018499549715,-0.277311877591,0.301448159602 +0.369621003307,0.018499549715,-0.227167215775,-0.452914378473 +0.369621003307,0.018499549715,-0.227167215775,-0.364165844582 +0.369621003307,0.018499549715,-0.227167215775,-0.319791577637 +0.369621003307,0.018499549715,-0.227167215775,-0.275417310691 +0.369621003307,0.018499549715,-0.227167215775,-0.1866687768 +0.369621003307,0.018499549715,-0.227167215775,-0.142294509854 +0.369621003307,0.018499549715,-0.227167215775,-0.0979202429087 +0.369621003307,0.018499549715,-0.227167215775,0.0352025579281 +0.369621003307,0.018499549715,-0.227167215775,0.0795768248736 +0.369621003307,0.018499549715,-0.227167215775,0.123951091819 +0.369621003307,0.018499549715,-0.227167215775,0.257073892656 +0.369621003307,0.018499549715,-0.227167215775,0.301448159602 +0.369621003307,0.018499549715,-0.227167215775,0.345822426547 +0.369621003307,0.018499549715,-0.227167215775,0.346266169217 +0.369621003307,0.018499549715,-0.126877892144,-0.452914378473 +0.369621003307,0.018499549715,-0.126877892144,-0.364165844582 +0.369621003307,0.018499549715,-0.126877892144,-0.319791577637 +0.369621003307,0.018499549715,-0.126877892144,-0.275417310691 +0.369621003307,0.018499549715,-0.126877892144,-0.1866687768 +0.369621003307,0.018499549715,-0.126877892144,-0.142294509854 +0.369621003307,0.018499549715,-0.126877892144,-0.0979202429087 +0.369621003307,0.018499549715,-0.126877892144,-0.0535459759631 +0.369621003307,0.018499549715,-0.126877892144,0.0352025579281 +0.369621003307,0.018499549715,-0.126877892144,0.0795768248736 +0.369621003307,0.018499549715,-0.126877892144,0.123951091819 +0.369621003307,0.018499549715,-0.126877892144,0.21269962571 +0.369621003307,0.018499549715,-0.126877892144,0.257073892656 +0.369621003307,0.018499549715,-0.126877892144,0.301448159602 +0.369621003307,0.018499549715,-0.126877892144,0.345822426547 +0.369621003307,0.018499549715,-0.126877892144,0.346266169217 +0.369621003307,0.018499549715,0.0737007551197,-0.452914378473 +0.369621003307,0.018499549715,0.0737007551197,-0.364165844582 +0.369621003307,0.018499549715,0.0737007551197,-0.319791577637 +0.369621003307,0.018499549715,0.0737007551197,-0.275417310691 +0.369621003307,0.018499549715,0.0737007551197,-0.1866687768 +0.369621003307,0.018499549715,0.0737007551197,-0.142294509854 +0.369621003307,0.018499549715,0.0737007551197,-0.0979202429087 +0.369621003307,0.018499549715,0.0737007551197,-0.0535459759631 +0.369621003307,0.018499549715,0.0737007551197,0.0352025579281 +0.369621003307,0.018499549715,0.0737007551197,0.0795768248736 +0.369621003307,0.018499549715,0.0737007551197,0.123951091819 +0.369621003307,0.018499549715,0.0737007551197,0.21269962571 +0.369621003307,0.018499549715,0.0737007551197,0.257073892656 +0.369621003307,0.018499549715,0.0737007551197,0.301448159602 +0.369621003307,0.018499549715,0.0737007551197,0.345822426547 +0.369621003307,0.018499549715,0.0737007551197,0.346266169217 +0.369621003307,0.018499549715,0.474858049646,-0.452914378473 +0.369621003307,0.018499549715,0.474858049646,-0.364165844582 +0.369621003307,0.018499549715,0.474858049646,-0.319791577637 +0.369621003307,0.018499549715,0.474858049646,-0.275417310691 +0.369621003307,0.018499549715,0.474858049646,-0.1866687768 +0.369621003307,0.018499549715,0.474858049646,-0.142294509854 +0.369621003307,0.018499549715,0.474858049646,-0.0979202429087 +0.369621003307,0.018499549715,0.474858049646,-0.0535459759631 +0.369621003307,0.018499549715,0.474858049646,0.0352025579281 +0.369621003307,0.018499549715,0.474858049646,0.0795768248736 +0.369621003307,0.018499549715,0.474858049646,0.123951091819 +0.369621003307,0.018499549715,0.474858049646,0.21269962571 +0.369621003307,0.018499549715,0.474858049646,0.257073892656 +0.369621003307,0.018499549715,0.474858049646,0.301448159602 +0.369621003307,0.018499549715,0.474858049646,0.345822426547 +0.369621003307,0.018499549715,0.474858049646,0.346266169217 +0.369621003307,0.657843987867,-0.314920373953,-0.142294509854 +0.369621003307,0.657843987867,-0.302384208499,-0.275417310691 +0.369621003307,0.657843987867,-0.227167215775,0.0352025579281 +0.369621003307,0.657843987867,-0.227167215775,0.0795768248736 +0.369621003307,0.657843987867,-0.227167215775,0.21269962571 +0.369621003307,0.657843987867,-0.227167215775,0.257073892656 +0.369621003307,0.657843987867,-0.227167215775,0.345822426547 +0.369621003307,0.657843987867,-0.126877892144,-0.1866687768 +0.369621003307,0.657843987867,-0.126877892144,-0.0979202429087 +0.369621003307,0.657843987867,-0.126877892144,0.0795768248736 +0.369621003307,0.657843987867,-0.126877892144,0.123951091819 +0.369621003307,0.657843987867,-0.126877892144,0.21269962571 +0.369621003307,0.657843987867,-0.126877892144,0.257073892656 +0.369621003307,0.657843987867,-0.126877892144,0.301448159602 +0.369621003307,0.657843987867,-0.126877892144,0.346266169217 +0.369621003307,0.657843987867,0.0737007551197,-0.364165844582 +0.369621003307,0.657843987867,0.0737007551197,-0.319791577637 +0.369621003307,0.657843987867,0.0737007551197,-0.275417310691 +0.369621003307,0.657843987867,0.0737007551197,-0.142294509854 +0.369621003307,0.657843987867,0.0737007551197,-0.0979202429087 +0.369621003307,0.657843987867,0.0737007551197,-0.0535459759631 +0.369621003307,0.657843987867,0.0737007551197,0.0352025579281 +0.369621003307,0.657843987867,0.0737007551197,0.0795768248736 +0.369621003307,0.657843987867,0.0737007551197,0.123951091819 +0.369621003307,0.657843987867,0.0737007551197,0.21269962571 +0.369621003307,0.657843987867,0.0737007551197,0.257073892656 +0.369621003307,0.657843987867,0.0737007551197,0.301448159602 +0.369621003307,0.657843987867,0.0737007551197,0.346266169217 +0.369621003307,0.657843987867,0.474858049646,-0.364165844582 +0.369621003307,0.657843987867,0.474858049646,-0.319791577637 +0.369621003307,0.657843987867,0.474858049646,-0.275417310691 +0.369621003307,0.657843987867,0.474858049646,-0.1866687768 +0.369621003307,0.657843987867,0.474858049646,-0.142294509854 +0.369621003307,0.657843987867,0.474858049646,-0.0979202429087 +0.369621003307,0.657843987867,0.474858049646,-0.0535459759631 +0.369621003307,0.657843987867,0.474858049646,0.0352025579281 +0.369621003307,0.657843987867,0.474858049646,0.0795768248736 +0.369621003307,0.657843987867,0.474858049646,0.123951091819 +0.369621003307,0.657843987867,0.474858049646,0.21269962571 +0.369621003307,0.657843987867,0.474858049646,0.257073892656 +0.369621003307,0.657843987867,0.474858049646,0.301448159602 +0.369621003307,0.657843987867,0.474858049646,0.345822426547 +54123792898.5 +121470858147 +3638106285000000 +1.60756296822E+016 +608968852347 +2109464220090 +1.95114323448E+016 +4.79511015336E+016 +71978621444.8 +171760606787 +213930254338000 +2260365986250000 +4952124766050 +12320033283100 +18142207372800 +23349208587600 +27139210849700 +45095480912600 +45959950912100 +51163249783600 +42594030297100 +50460588023300 +117020581223000 +124276974592000 +135657389827000 +134058184922000 +155909903633000 +158623679039000 +149101586975000 +170110125803000 +189379130153000 +202649417664000 +211606038624000 +192221177785000 +310890509435000 +343863284608000 +325678957772000 +430809541156000 +509621237708000 +423033880026000 +587071910573000 +680623907917000 +744742195421000 +795203232880000 +936678892190000 +881246682507000 +942993570599000 +955993905096000 +860542692784000 +1039364661380000 +1245405462050000 +1297388336310000 +1370245414670000 +1663128355590000 +1814361376710000 +2105318599640000 +2100298307320000 +2599649103740000 +2578738300900000 +3025342943800000 +3135923494500000 +3564861626750000 +3570025096130000 +3686213190440000 +4669723123710000 +4684898895170000 +4826719683910000 +5389749756370000 +6044534351550000 +6851325747950000 +7734567028680000 +7779297080670000 +9.30286332418E+015 +1.00926858565E+016 +1.05522151095E+016 +1.21982910604E+016 +1.2609992587E+016 +1.33405755608E+016 +1.42671665485E+016 +4285579243840 +16084877279900 +13277413905400 +17174788896100 +28180447438100 +32138189428900 +33160385962500 +36238363635100 +38751306559100 +48268216906400 +82569478769100 +92601210196700 +106956785402000 +113490453007000 +127675249201000 +131124594596000 +128763881757000 +141227807849000 +121464378127000 +143027796318000 +137027644341000 +289027586148000 +296147332944000 +303981082985000 +336882250985000 +366369655254000 +351465670160000 +363887455886000 +385379497093000 +389405201045000 +426642309866000 +383576600737000 +403423009896000 +466777994043000 +393024969784000 +1.07529193278E+015 +1212290395850000 +1360495959340000 +1267032305850000 +1579946207100000 +1682730063730000 +1837083159410000 +1952434534600000 +2258066181040000 +2199017638930000 +2369976083480000 +2508934799420000 +2615627160430000 +2467736541880000 +2311519439160000 +2512342637980000 +4821893659190000 +5211870731540000 +5108186953080000 +5880905088600000 +6409003486990000 +7212228267580000 +7301329218060000 +8120246131829999 +8917162511430000 +9.44600159965E+015 +9.92519305348E+015 +1.06847967479E+016 +1.11602461031E+016 +1.16605949281E+016 +1.2404906342E+016 +1.47082922807E+016 +1.9334186207E+016 +2.13511675373E+016 +2.14548308013E+016 +2.2859694152E+016 +2.59389616184E+016 +2.87801886438E+016 +2.78806945582E+016 +3.01488266172E+016 +3.64364012616E+016 +3.25456520238E+016 +3.47706674567E+016 +4.17357684136E+016 +4.28330927938E+016 +4.61746688249E+016 +4.68746738207E+016 +5.86310092028E+016 +161313172246 +6146526348210 +7100908376540 +8894783132820 +9759943236600 +21423689301300 +29089817483500 +34093380254800 +35164311442600 +43848080490600 +53886899790600 +67874183459300 +106021835044000 +77891036339500 +99061284120300 +100403765820000 +93645420902800 +144469815731000 +179151679296000 +160491636495000 +194372691490000 +217725481323000 +264204514987000 +273939300389000 +284658524669000 +290171264538000 +297842220440000 +349831569845000 +353265521656000 +308013338658000 +386805934395000 +604122205000000 +722717949023000 +749850832551000 +824653093717000 +941936090972000 +1008413510510000 +1.08548059417E+015 +1.09829839811E+015 +1462322494640000 +1586488666570000 +1726228067520000 +1923715305150000 +1419911971280000 +1716396258210000 +1684446185460000 +1451929761320000 +2376387855790000 +2649902169240000 +3066230645040000 +3726146925770000 +4030518397640000 +4059079175860000 +4500661601090000 +5772453637770000 +6007838111710000 +6815348851990000 +7616939522400000 +8312821381450000 +8738898800779999 +9.11630169607E+015 +1.09835614115E+016 +8343780006159999 +1.08306165432E+016 +1.24988238013E+016 +1.3468271848E+016 +1.59065184514E+016 +1.75313776237E+016 +1.76683606367E+016 +1.9866608854E+016 +2.55440361956E+016 +2.5635755578E+016 +2.68937730675E+016 +3.1368597008E+016 +3.39406468359E+016 +3.79073721256E+016 +3.71035574968E+016 +4.73307069277E+016 +14548576521000 +22617940609900 +30416035115500 +24369589167900 +25521710913900 +26256508403600 +70613243515300 +75711163713700 +88667662560800 +78846150858700 +101304530408000 +73820439039100 +86134451492900 +97120102547600 +107937470928000 +76772646861400 +95768123137600 +259824500199000 +259036048936000 +317361440008000 +280161847991000 +357554600763000 +354835053285000 +334707061497000 +296837869770000 +356701295781000 +355796792955000 +435834817407000 +348390160037000 +570792101029000 +441676120624000 +1243375266240000 +1.07168673783E+015 +1338815069960000 +1335943361720000 +1409272934510000 +1293485118490000 +1441102243750000 +1699362645320000 +1958946332550000 +1993752638680000 +1714871826870000 +1644847813380000 +2040549880390000 +1.95324833727E+015 +1835901040890000 +4077632427900000 +4889358610380000 +4697639417870000 +5135152422500000 +5000526808520000 +5831774490310000 +5605058618770000 +5824399422830000 +6364100327060000 +6532097085870000 +7046024070610000 +7058208648170000 +8823823172159999 +8565404304579999 +7429792866730000 +8135844935040000 +2.10475722875E+016 +1.71297623448E+016 +2.17527304455E+016 +2.62743616984E+016 +2.0605339779E+016 +2.45471732842E+016 +2.66092897977E+016 +3.23551690226E+016 +2.46590658581E+016 +2.93431136321E+016 +3.70602446674E+016 +3.96026518214E+016 +3.68405194831E+016 +4.41958125837E+016 +1756374854070 +2556174983140 +8111595952740 +19832031992500 +11140556807000 +40621373640000 +63844995591500 +58316526435100 +49282223580700 +57328401189200 +51861080687500 +55613140260100 +132176990525000 +200313850588000 +174859753820000 +187684112868000 +190568512012000 +238351890972000 +185145019845000 +262597022284000 +233368141744000 +292675777437000 +305566175200000 +247592610994000 +314860222428000 +286685200916000 +740023584612000 +686988468141000 +695786792995000 +816213001296000 +915602863083000 +878027958723000 +888582874165000 +974544517036000 +868889259897000 +1182941925080000 +963103253627000 +1262014020880000 +1146522461310000 +1386542698880000 +1198601438000000 +1314124018070000 +2725958694180000 +2475524399380000 +3041646727840000 +3292886381200000 +3700247028600000 +3161457499880000 +3898961472050000 +3698701351470000 +4407324534340000 +4.08190725049E+015 +4186550068870000 +3926453399800000 +5392945300410000 +4435321286360000 +5047417285370000 +5054628605600000 +1.3109495594E+016 +1.09403912425E+016 +9.99676438926E+015 +1.0767202472E+016 +1.43210146701E+016 +1.35894311704E+016 +1.3422289038E+016 +1.27240570228E+016 +1.97166329127E+016 +1.75182168132E+016 +1.85349216508E+016 +1.91821683896E+016 +2.03133755825E+016 +1.81906352935E+016 +2.29978882342E+016 +2.00913447742E+016 +988956603493 +3553603079600 +62958418004000 +59400524191400 +83407450316900 +65572677829700 +84364531918100 +72480150655100 +91424775022100 +204977960789000 +112276529053000 +270065974142000 +208000523684000 +226507716826000 +278686789834000 +203510820353000 +224510263726000 +186154630320000 +239667454588000 +408940190264000 +447587807344000 +412428554779000 +395727033684000 +371527732444000 +468010465514000 +553990494377000 +535098907444000 +654773728324000 +978214755119000 +797892944175000 +895482127406000 +1195840287340000 +723687815191000 +1532191746940000 +1915578681090000 +1594102374250000 +1493104126630000 +736986471019000 +1519998138570000 +2414228080600000 +1435918033030000 +1561546945390000 +-0.429559544383,-0.141336559823,-0.324322498044,-0.364165844582 +-0.429559544383,-0.141336559823,-0.324322498044,-0.319791577637 +-0.429559544383,-0.141336559823,-0.324322498044,-0.275417310691 +-0.429559544383,-0.141336559823,-0.324322498044,-0.1866687768 +-0.429559544383,-0.141336559823,-0.324322498044,-0.142294509854 +-0.429559544383,-0.141336559823,-0.324322498044,-0.0979202429087 +-0.429559544383,-0.141336559823,-0.324322498044,-0.0535459759631 +-0.429559544383,-0.141336559823,-0.324322498044,0.0352025579281 +-0.429559544383,-0.141336559823,-0.324322498044,0.0795768248736 +-0.429559544383,-0.141336559823,-0.324322498044,0.123951091819 +-0.429559544383,-0.141336559823,-0.324322498044,0.21269962571 +-0.429559544383,-0.141336559823,-0.324322498044,0.257073892656 +-0.429559544383,-0.141336559823,-0.324322498044,0.301448159602 +-0.429559544383,-0.141336559823,-0.324322498044,0.345822426547 +-0.429559544383,-0.141336559823,-0.32118845668,-0.452914378473 +-0.429559544383,-0.141336559823,-0.32118845668,-0.364165844582 +-0.429559544383,-0.141336559823,-0.32118845668,-0.319791577637 +-0.429559544383,-0.141336559823,-0.32118845668,-0.275417310691 +-0.429559544383,-0.141336559823,-0.32118845668,-0.1866687768 +-0.429559544383,-0.141336559823,-0.32118845668,-0.142294509854 +-0.429559544383,-0.141336559823,-0.32118845668,-0.0979202429087 +-0.429559544383,-0.141336559823,-0.32118845668,-0.0535459759631 +-0.429559544383,-0.141336559823,-0.32118845668,0.0352025579281 +-0.429559544383,-0.141336559823,-0.32118845668,0.0795768248736 +-0.429559544383,-0.141336559823,-0.32118845668,0.123951091819 +-0.429559544383,-0.141336559823,-0.32118845668,0.21269962571 +-0.429559544383,-0.141336559823,-0.32118845668,0.257073892656 +-0.429559544383,-0.141336559823,-0.32118845668,0.301448159602 +-0.429559544383,-0.141336559823,-0.32118845668,0.345822426547 +-0.429559544383,-0.141336559823,-0.32118845668,0.346266169217 +-0.429559544383,-0.141336559823,-0.314920373953,-0.452914378473 +-0.429559544383,-0.141336559823,-0.314920373953,-0.364165844582 +-0.429559544383,-0.141336559823,-0.314920373953,-0.319791577637 +-0.429559544383,-0.141336559823,-0.314920373953,-0.275417310691 +-0.429559544383,-0.141336559823,-0.314920373953,-0.1866687768 +-0.429559544383,-0.141336559823,-0.314920373953,-0.142294509854 +-0.429559544383,-0.141336559823,-0.314920373953,-0.0979202429087 +-0.429559544383,-0.141336559823,-0.314920373953,-0.0535459759631 +-0.429559544383,-0.141336559823,-0.314920373953,0.0352025579281 +-0.429559544383,-0.141336559823,-0.314920373953,0.0795768248736 +-0.429559544383,-0.141336559823,-0.314920373953,0.123951091819 +-0.429559544383,-0.141336559823,-0.314920373953,0.21269962571 +-0.429559544383,-0.141336559823,-0.314920373953,0.257073892656 +-0.429559544383,-0.141336559823,-0.314920373953,0.301448159602 +-0.429559544383,-0.141336559823,-0.314920373953,0.345822426547 +-0.429559544383,-0.141336559823,-0.314920373953,0.346266169217 +-0.429559544383,-0.141336559823,-0.302384208499,-0.364165844582 +-0.429559544383,-0.141336559823,-0.302384208499,-0.319791577637 +-0.429559544383,-0.141336559823,-0.302384208499,-0.275417310691 +-0.429559544383,-0.141336559823,-0.302384208499,-0.1866687768 +-0.429559544383,-0.141336559823,-0.302384208499,-0.142294509854 +-0.429559544383,-0.141336559823,-0.302384208499,-0.0979202429087 +-0.429559544383,-0.141336559823,-0.302384208499,-0.0535459759631 +-0.429559544383,-0.141336559823,-0.302384208499,0.0352025579281 +-0.429559544383,-0.141336559823,-0.302384208499,0.0795768248736 +-0.429559544383,-0.141336559823,-0.302384208499,0.123951091819 +-0.429559544383,-0.141336559823,-0.302384208499,0.257073892656 +-0.429559544383,-0.141336559823,-0.302384208499,0.301448159602 +-0.429559544383,-0.141336559823,-0.302384208499,0.345822426547 +-0.429559544383,-0.141336559823,-0.302384208499,0.346266169217 +-0.429559544383,-0.141336559823,-0.277311877591,-0.319791577637 +-0.429559544383,-0.141336559823,-0.277311877591,-0.1866687768 +-0.429559544383,-0.141336559823,-0.277311877591,-0.142294509854 +-0.429559544383,-0.141336559823,-0.277311877591,-0.0979202429087 +-0.429559544383,-0.141336559823,-0.277311877591,-0.0535459759631 +-0.429559544383,-0.141336559823,-0.277311877591,0.0352025579281 +-0.429559544383,-0.141336559823,-0.277311877591,0.257073892656 +-0.429559544383,-0.141336559823,-0.277311877591,0.301448159602 +-0.429559544383,-0.141336559823,-0.227167215775,-0.452914378473 +-0.429559544383,-0.141336559823,-0.227167215775,-0.364165844582 +-0.429559544383,-0.141336559823,-0.227167215775,-0.319791577637 +-0.429559544383,-0.141336559823,-0.227167215775,-0.275417310691 +-0.429559544383,-0.141336559823,-0.126877892144,-0.452914378473 +-0.269723434845,-0.141336559823,-0.324322498044,-0.452914378473 +-0.269723434845,-0.141336559823,-0.324322498044,-0.364165844582 +-0.269723434845,-0.141336559823,-0.324322498044,-0.319791577637 +-0.269723434845,-0.141336559823,-0.324322498044,-0.275417310691 +-0.269723434845,-0.141336559823,-0.324322498044,-0.1866687768 +-0.269723434845,-0.141336559823,-0.324322498044,-0.142294509854 +-0.269723434845,-0.141336559823,-0.324322498044,-0.0979202429087 +-0.269723434845,-0.141336559823,-0.324322498044,-0.0535459759631 +-0.269723434845,-0.141336559823,-0.324322498044,0.0352025579281 +-0.269723434845,-0.141336559823,-0.324322498044,0.0795768248736 +-0.269723434845,-0.141336559823,-0.324322498044,0.123951091819 +-0.269723434845,-0.141336559823,-0.324322498044,0.21269962571 +-0.269723434845,-0.141336559823,-0.324322498044,0.257073892656 +-0.269723434845,-0.141336559823,-0.324322498044,0.301448159602 +-0.269723434845,-0.141336559823,-0.324322498044,0.345822426547 +-0.269723434845,-0.141336559823,-0.324322498044,0.346266169217 +-0.269723434845,-0.141336559823,-0.32118845668,-0.452914378473 +-0.269723434845,-0.141336559823,-0.32118845668,-0.364165844582 +-0.269723434845,-0.141336559823,-0.32118845668,-0.319791577637 +-0.269723434845,-0.141336559823,-0.32118845668,-0.275417310691 +-0.269723434845,-0.141336559823,-0.32118845668,-0.1866687768 +-0.269723434845,-0.141336559823,-0.32118845668,-0.142294509854 +-0.269723434845,-0.141336559823,-0.32118845668,-0.0979202429087 +-0.269723434845,-0.141336559823,-0.32118845668,-0.0535459759631 +-0.269723434845,-0.141336559823,-0.32118845668,0.0352025579281 +-0.269723434845,-0.141336559823,-0.32118845668,0.0795768248736 +-0.269723434845,-0.141336559823,-0.32118845668,0.123951091819 +-0.269723434845,-0.141336559823,-0.32118845668,0.257073892656 +-0.269723434845,-0.141336559823,-0.32118845668,0.301448159602 +-0.269723434845,-0.141336559823,-0.32118845668,0.345822426547 +-0.269723434845,-0.141336559823,-0.32118845668,0.346266169217 +-0.269723434845,-0.141336559823,-0.314920373953,-0.452914378473 +-0.269723434845,-0.141336559823,-0.314920373953,-0.364165844582 +-0.269723434845,-0.141336559823,-0.314920373953,-0.319791577637 +-0.269723434845,-0.141336559823,-0.314920373953,-0.275417310691 +-0.269723434845,-0.141336559823,-0.314920373953,-0.1866687768 +-0.269723434845,-0.141336559823,-0.314920373953,-0.142294509854 +-0.269723434845,-0.141336559823,-0.314920373953,-0.0979202429087 +-0.269723434845,-0.141336559823,-0.314920373953,-0.0535459759631 +-0.269723434845,-0.141336559823,-0.314920373953,0.123951091819 +-0.269723434845,-0.141336559823,-0.314920373953,0.21269962571 +-0.269723434845,-0.141336559823,-0.314920373953,0.257073892656 +-0.269723434845,-0.141336559823,-0.314920373953,0.345822426547 +-0.269723434845,-0.141336559823,-0.314920373953,0.346266169217 +-0.269723434845,-0.141336559823,-0.302384208499,-0.452914378473 +-0.269723434845,-0.141336559823,-0.302384208499,-0.319791577637 +-0.269723434845,-0.141336559823,-0.302384208499,-0.142294509854 +-0.269723434845,-0.141336559823,-0.302384208499,-0.0535459759631 +-0.269723434845,-0.141336559823,-0.302384208499,0.0352025579281 +-0.269723434845,-0.141336559823,-0.302384208499,0.123951091819 +-0.269723434845,-0.141336559823,-0.302384208499,0.21269962571 +-0.269723434845,-0.141336559823,-0.302384208499,0.257073892656 +-0.269723434845,-0.141336559823,-0.302384208499,0.345822426547 +-0.269723434845,-0.141336559823,-0.302384208499,0.346266169217 +-0.269723434845,-0.141336559823,-0.277311877591,-0.364165844582 +-0.269723434845,-0.141336559823,-0.277311877591,-0.319791577637 +-0.269723434845,-0.141336559823,-0.277311877591,-0.1866687768 +-0.269723434845,-0.141336559823,-0.277311877591,-0.0535459759631 +-0.269723434845,-0.141336559823,-0.277311877591,0.301448159602 +-0.269723434845,-0.141336559823,-0.227167215775,-0.1866687768 +-0.269723434845,-0.141336559823,-0.227167215775,-0.142294509854 +-0.269723434845,0.018499549715,-0.324322498044,-0.364165844582 +-0.269723434845,0.018499549715,-0.324322498044,-0.319791577637 +-0.269723434845,0.018499549715,-0.324322498044,-0.275417310691 +-0.269723434845,0.018499549715,-0.324322498044,-0.1866687768 +-0.269723434845,0.018499549715,-0.324322498044,-0.142294509854 +-0.269723434845,0.018499549715,-0.324322498044,-0.0979202429087 +-0.269723434845,0.018499549715,-0.324322498044,-0.0535459759631 +-0.269723434845,0.018499549715,-0.324322498044,0.0352025579281 +-0.269723434845,0.018499549715,-0.324322498044,0.0795768248736 +-0.269723434845,0.018499549715,-0.324322498044,0.123951091819 +-0.269723434845,0.018499549715,-0.324322498044,0.21269962571 +-0.269723434845,0.018499549715,-0.324322498044,0.257073892656 +-0.269723434845,0.018499549715,-0.324322498044,0.301448159602 +-0.269723434845,0.018499549715,-0.324322498044,0.345822426547 +-0.269723434845,0.018499549715,-0.324322498044,0.346266169217 +-0.269723434845,0.018499549715,-0.32118845668,-0.452914378473 +-0.269723434845,0.018499549715,-0.32118845668,-0.364165844582 +-0.269723434845,0.018499549715,-0.32118845668,-0.319791577637 +-0.269723434845,0.018499549715,-0.32118845668,-0.275417310691 +-0.269723434845,0.018499549715,-0.32118845668,-0.1866687768 +-0.269723434845,0.018499549715,-0.32118845668,-0.142294509854 +-0.269723434845,0.018499549715,-0.32118845668,-0.0979202429087 +-0.269723434845,0.018499549715,-0.32118845668,-0.0535459759631 +-0.269723434845,0.018499549715,-0.32118845668,0.0352025579281 +-0.269723434845,0.018499549715,-0.32118845668,0.0795768248736 +-0.269723434845,0.018499549715,-0.32118845668,0.123951091819 +-0.269723434845,0.018499549715,-0.32118845668,0.21269962571 +-0.269723434845,0.018499549715,-0.32118845668,0.257073892656 +-0.269723434845,0.018499549715,-0.32118845668,0.301448159602 +-0.269723434845,0.018499549715,-0.32118845668,0.345822426547 +-0.269723434845,0.018499549715,-0.32118845668,0.346266169217 +-0.269723434845,0.018499549715,-0.314920373953,-0.452914378473 +-0.269723434845,0.018499549715,-0.314920373953,-0.364165844582 +-0.269723434845,0.018499549715,-0.314920373953,-0.319791577637 +-0.269723434845,0.018499549715,-0.314920373953,-0.275417310691 +-0.269723434845,0.018499549715,-0.314920373953,-0.1866687768 +-0.269723434845,0.018499549715,-0.314920373953,-0.142294509854 +-0.269723434845,0.018499549715,-0.314920373953,-0.0979202429087 +-0.269723434845,0.018499549715,-0.314920373953,-0.0535459759631 +-0.269723434845,0.018499549715,-0.314920373953,0.0352025579281 +-0.269723434845,0.018499549715,-0.314920373953,0.123951091819 +-0.269723434845,0.018499549715,-0.314920373953,0.21269962571 +-0.269723434845,0.018499549715,-0.314920373953,0.257073892656 +-0.269723434845,0.018499549715,-0.314920373953,0.345822426547 +-0.269723434845,0.018499549715,-0.302384208499,-0.364165844582 +-0.269723434845,0.018499549715,-0.302384208499,-0.319791577637 +-0.269723434845,0.018499549715,-0.302384208499,-0.275417310691 +-0.269723434845,0.018499549715,-0.302384208499,-0.1866687768 +-0.269723434845,0.018499549715,-0.302384208499,-0.142294509854 +-0.269723434845,0.018499549715,-0.302384208499,-0.0979202429087 +-0.269723434845,0.018499549715,-0.302384208499,-0.0535459759631 +-0.269723434845,0.018499549715,-0.302384208499,0.0352025579281 +-0.269723434845,0.018499549715,-0.302384208499,0.123951091819 +-0.269723434845,0.018499549715,-0.302384208499,0.257073892656 +-0.269723434845,0.018499549715,-0.302384208499,0.301448159602 +-0.269723434845,0.018499549715,-0.302384208499,0.346266169217 +-0.269723434845,0.018499549715,-0.277311877591,-0.319791577637 +-0.269723434845,0.018499549715,-0.277311877591,-0.1866687768 +-0.269723434845,0.018499549715,-0.277311877591,-0.142294509854 +-0.269723434845,0.018499549715,-0.277311877591,-0.0535459759631 +-0.269723434845,0.018499549715,-0.277311877591,0.0352025579281 +-0.269723434845,0.018499549715,-0.277311877591,0.257073892656 +-0.269723434845,0.018499549715,-0.277311877591,0.346266169217 +-0.269723434845,0.018499549715,-0.227167215775,0.123951091819 +-0.269723434845,0.018499549715,-0.227167215775,0.21269962571 +-0.269723434845,0.018499549715,0.0737007551197,-0.364165844582 +0.369621003307,-0.141336559823,-0.324322498044,-0.364165844582 +0.369621003307,-0.141336559823,-0.324322498044,-0.319791577637 +0.369621003307,-0.141336559823,-0.324322498044,-0.275417310691 +0.369621003307,-0.141336559823,-0.324322498044,-0.1866687768 +0.369621003307,-0.141336559823,-0.324322498044,-0.142294509854 +0.369621003307,-0.141336559823,-0.324322498044,-0.0979202429087 +0.369621003307,-0.141336559823,-0.324322498044,-0.0535459759631 +0.369621003307,-0.141336559823,-0.324322498044,0.0352025579281 +0.369621003307,-0.141336559823,-0.324322498044,0.0795768248736 +0.369621003307,-0.141336559823,-0.324322498044,0.123951091819 +0.369621003307,-0.141336559823,-0.324322498044,0.21269962571 +0.369621003307,-0.141336559823,-0.324322498044,0.257073892656 +0.369621003307,-0.141336559823,-0.324322498044,0.301448159602 +0.369621003307,-0.141336559823,-0.324322498044,0.345822426547 +0.369621003307,-0.141336559823,-0.32118845668,-0.452914378473 +0.369621003307,-0.141336559823,-0.32118845668,-0.364165844582 +0.369621003307,-0.141336559823,-0.32118845668,-0.319791577637 +0.369621003307,-0.141336559823,-0.32118845668,-0.275417310691 +0.369621003307,-0.141336559823,-0.32118845668,-0.1866687768 +0.369621003307,-0.141336559823,-0.32118845668,-0.142294509854 +0.369621003307,-0.141336559823,-0.32118845668,-0.0979202429087 +0.369621003307,-0.141336559823,-0.32118845668,-0.0535459759631 +0.369621003307,-0.141336559823,-0.32118845668,0.0352025579281 +0.369621003307,-0.141336559823,-0.32118845668,0.0795768248736 +0.369621003307,-0.141336559823,-0.32118845668,0.123951091819 +0.369621003307,-0.141336559823,-0.32118845668,0.21269962571 +0.369621003307,-0.141336559823,-0.32118845668,0.257073892656 +0.369621003307,-0.141336559823,-0.32118845668,0.301448159602 +0.369621003307,-0.141336559823,-0.32118845668,0.345822426547 +0.369621003307,-0.141336559823,-0.32118845668,0.346266169217 +0.369621003307,-0.141336559823,-0.314920373953,-0.452914378473 +0.369621003307,-0.141336559823,-0.314920373953,-0.364165844582 +0.369621003307,-0.141336559823,-0.314920373953,-0.319791577637 +0.369621003307,-0.141336559823,-0.314920373953,-0.275417310691 +0.369621003307,-0.141336559823,-0.314920373953,-0.1866687768 +0.369621003307,-0.141336559823,-0.314920373953,-0.142294509854 +0.369621003307,-0.141336559823,-0.314920373953,-0.0979202429087 +0.369621003307,-0.141336559823,-0.314920373953,-0.0535459759631 +0.369621003307,-0.141336559823,-0.314920373953,0.0352025579281 +0.369621003307,-0.141336559823,-0.314920373953,0.0795768248736 +0.369621003307,-0.141336559823,-0.314920373953,0.123951091819 +0.369621003307,-0.141336559823,-0.314920373953,0.21269962571 +0.369621003307,-0.141336559823,-0.314920373953,0.301448159602 +0.369621003307,-0.141336559823,-0.314920373953,0.345822426547 +0.369621003307,-0.141336559823,-0.314920373953,0.346266169217 +0.369621003307,-0.141336559823,-0.302384208499,-0.452914378473 +0.369621003307,-0.141336559823,-0.302384208499,-0.364165844582 +0.369621003307,-0.141336559823,-0.302384208499,-0.319791577637 +0.369621003307,-0.141336559823,-0.302384208499,-0.275417310691 +0.369621003307,-0.141336559823,-0.302384208499,-0.142294509854 +0.369621003307,-0.141336559823,-0.302384208499,-0.0979202429087 +0.369621003307,-0.141336559823,-0.302384208499,-0.0535459759631 +0.369621003307,-0.141336559823,-0.302384208499,0.123951091819 +0.369621003307,-0.141336559823,-0.302384208499,0.257073892656 +0.369621003307,-0.141336559823,-0.302384208499,0.301448159602 +0.369621003307,-0.141336559823,-0.302384208499,0.346266169217 +0.369621003307,-0.141336559823,-0.277311877591,-0.364165844582 +0.369621003307,-0.141336559823,-0.277311877591,-0.319791577637 +0.369621003307,-0.141336559823,-0.277311877591,-0.275417310691 +0.369621003307,-0.141336559823,-0.277311877591,0.0795768248736 +0.369621003307,-0.141336559823,-0.277311877591,0.346266169217 +0.369621003307,-0.141336559823,-0.227167215775,-0.142294509854 +0.369621003307,-0.141336559823,-0.227167215775,0.301448159602 +0.369621003307,-0.141336559823,-0.126877892144,0.0352025579281 +0.369621003307,0.018499549715,-0.324322498044,-0.452914378473 +0.369621003307,0.018499549715,-0.324322498044,-0.364165844582 +0.369621003307,0.018499549715,-0.324322498044,-0.319791577637 +0.369621003307,0.018499549715,-0.324322498044,-0.275417310691 +0.369621003307,0.018499549715,-0.324322498044,-0.1866687768 +0.369621003307,0.018499549715,-0.324322498044,-0.142294509854 +0.369621003307,0.018499549715,-0.324322498044,-0.0979202429087 +0.369621003307,0.018499549715,-0.324322498044,-0.0535459759631 +0.369621003307,0.018499549715,-0.324322498044,0.0352025579281 +0.369621003307,0.018499549715,-0.324322498044,0.0795768248736 +0.369621003307,0.018499549715,-0.324322498044,0.123951091819 +0.369621003307,0.018499549715,-0.324322498044,0.21269962571 +0.369621003307,0.018499549715,-0.324322498044,0.257073892656 +0.369621003307,0.018499549715,-0.324322498044,0.301448159602 +0.369621003307,0.018499549715,-0.324322498044,0.345822426547 +0.369621003307,0.018499549715,-0.324322498044,0.346266169217 +0.369621003307,0.018499549715,-0.32118845668,-0.364165844582 +0.369621003307,0.018499549715,-0.32118845668,-0.319791577637 +0.369621003307,0.018499549715,-0.32118845668,-0.275417310691 +0.369621003307,0.018499549715,-0.32118845668,-0.142294509854 +0.369621003307,0.018499549715,-0.32118845668,-0.0979202429087 +0.369621003307,0.018499549715,-0.32118845668,-0.0535459759631 +0.369621003307,0.018499549715,-0.32118845668,0.0352025579281 +0.369621003307,0.018499549715,-0.32118845668,0.0795768248736 +0.369621003307,0.018499549715,-0.32118845668,0.123951091819 +0.369621003307,0.018499549715,-0.32118845668,0.21269962571 +0.369621003307,0.018499549715,-0.32118845668,0.257073892656 +0.369621003307,0.018499549715,-0.32118845668,0.301448159602 +0.369621003307,0.018499549715,-0.32118845668,0.345822426547 +0.369621003307,0.018499549715,-0.32118845668,0.346266169217 +0.369621003307,0.018499549715,-0.314920373953,-0.452914378473 +0.369621003307,0.018499549715,-0.314920373953,-0.364165844582 +0.369621003307,0.018499549715,-0.314920373953,-0.319791577637 +0.369621003307,0.018499549715,-0.314920373953,-0.275417310691 +0.369621003307,0.018499549715,-0.314920373953,-0.1866687768 +0.369621003307,0.018499549715,-0.314920373953,-0.142294509854 +0.369621003307,0.018499549715,-0.314920373953,-0.0979202429087 +0.369621003307,0.018499549715,-0.314920373953,-0.0535459759631 +0.369621003307,0.018499549715,-0.314920373953,0.0352025579281 +0.369621003307,0.018499549715,-0.314920373953,0.123951091819 +0.369621003307,0.018499549715,-0.314920373953,0.21269962571 +0.369621003307,0.018499549715,-0.314920373953,0.257073892656 +0.369621003307,0.018499549715,-0.314920373953,0.301448159602 +0.369621003307,0.018499549715,-0.314920373953,0.345822426547 +0.369621003307,0.018499549715,-0.314920373953,0.346266169217 +0.369621003307,0.018499549715,-0.302384208499,-0.452914378473 +0.369621003307,0.018499549715,-0.302384208499,-0.364165844582 +0.369621003307,0.018499549715,-0.302384208499,-0.319791577637 +0.369621003307,0.018499549715,-0.302384208499,-0.275417310691 +0.369621003307,0.018499549715,-0.302384208499,-0.1866687768 +0.369621003307,0.018499549715,-0.302384208499,-0.142294509854 +0.369621003307,0.018499549715,-0.302384208499,-0.0979202429087 +0.369621003307,0.018499549715,-0.302384208499,0.0352025579281 +0.369621003307,0.018499549715,-0.302384208499,0.123951091819 +0.369621003307,0.018499549715,-0.302384208499,0.21269962571 +0.369621003307,0.018499549715,-0.302384208499,0.257073892656 +0.369621003307,0.018499549715,-0.302384208499,0.301448159602 +0.369621003307,0.018499549715,-0.302384208499,0.345822426547 +0.369621003307,0.018499549715,-0.302384208499,0.346266169217 +0.369621003307,0.018499549715,-0.277311877591,-0.364165844582 +0.369621003307,0.018499549715,-0.277311877591,-0.319791577637 +0.369621003307,0.018499549715,-0.277311877591,-0.275417310691 +0.369621003307,0.018499549715,-0.277311877591,-0.0535459759631 +0.369621003307,0.018499549715,-0.277311877591,0.0352025579281 +0.369621003307,0.018499549715,-0.277311877591,0.21269962571 +0.369621003307,0.018499549715,-0.277311877591,0.257073892656 +0.369621003307,0.018499549715,-0.277311877591,0.345822426547 +0.369621003307,0.018499549715,-0.277311877591,0.346266169217 +0.369621003307,0.018499549715,-0.227167215775,-0.0535459759631 +0.369621003307,0.018499549715,-0.227167215775,0.21269962571 +0.369621003307,0.657843987867,-0.324322498044,-0.364165844582 +0.369621003307,0.657843987867,-0.324322498044,-0.319791577637 +0.369621003307,0.657843987867,-0.324322498044,-0.275417310691 +0.369621003307,0.657843987867,-0.324322498044,-0.1866687768 +0.369621003307,0.657843987867,-0.324322498044,-0.142294509854 +0.369621003307,0.657843987867,-0.324322498044,-0.0979202429087 +0.369621003307,0.657843987867,-0.324322498044,-0.0535459759631 +0.369621003307,0.657843987867,-0.324322498044,0.0352025579281 +0.369621003307,0.657843987867,-0.324322498044,0.0795768248736 +0.369621003307,0.657843987867,-0.324322498044,0.123951091819 +0.369621003307,0.657843987867,-0.324322498044,0.21269962571 +0.369621003307,0.657843987867,-0.324322498044,0.257073892656 +0.369621003307,0.657843987867,-0.324322498044,0.301448159602 +0.369621003307,0.657843987867,-0.324322498044,0.345822426547 +0.369621003307,0.657843987867,-0.32118845668,-0.452914378473 +0.369621003307,0.657843987867,-0.32118845668,-0.364165844582 +0.369621003307,0.657843987867,-0.32118845668,-0.319791577637 +0.369621003307,0.657843987867,-0.32118845668,-0.275417310691 +0.369621003307,0.657843987867,-0.32118845668,-0.1866687768 +0.369621003307,0.657843987867,-0.32118845668,-0.142294509854 +0.369621003307,0.657843987867,-0.32118845668,-0.0979202429087 +0.369621003307,0.657843987867,-0.32118845668,-0.0535459759631 +0.369621003307,0.657843987867,-0.32118845668,0.0352025579281 +0.369621003307,0.657843987867,-0.32118845668,0.0795768248736 +0.369621003307,0.657843987867,-0.32118845668,0.123951091819 +0.369621003307,0.657843987867,-0.32118845668,0.21269962571 +0.369621003307,0.657843987867,-0.32118845668,0.257073892656 +0.369621003307,0.657843987867,-0.32118845668,0.301448159602 +0.369621003307,0.657843987867,-0.32118845668,0.345822426547 +0.369621003307,0.657843987867,-0.32118845668,0.346266169217 +0.369621003307,0.657843987867,-0.314920373953,-0.452914378473 +0.369621003307,0.657843987867,-0.314920373953,-0.364165844582 +0.369621003307,0.657843987867,-0.314920373953,-0.319791577637 +0.369621003307,0.657843987867,-0.314920373953,-0.275417310691 +0.369621003307,0.657843987867,-0.314920373953,-0.1866687768 +0.369621003307,0.657843987867,-0.314920373953,-0.0979202429087 +0.369621003307,0.657843987867,-0.314920373953,-0.0535459759631 +0.369621003307,0.657843987867,-0.314920373953,0.0352025579281 +0.369621003307,0.657843987867,-0.314920373953,0.0795768248736 +0.369621003307,0.657843987867,-0.314920373953,0.123951091819 +0.369621003307,0.657843987867,-0.314920373953,0.21269962571 +0.369621003307,0.657843987867,-0.314920373953,0.257073892656 +0.369621003307,0.657843987867,-0.314920373953,0.301448159602 +0.369621003307,0.657843987867,-0.314920373953,0.345822426547 +0.369621003307,0.657843987867,-0.314920373953,0.346266169217 +0.369621003307,0.657843987867,-0.302384208499,-0.452914378473 +0.369621003307,0.657843987867,-0.302384208499,-0.364165844582 +0.369621003307,0.657843987867,-0.302384208499,-0.319791577637 +0.369621003307,0.657843987867,-0.302384208499,-0.1866687768 +0.369621003307,0.657843987867,-0.302384208499,-0.142294509854 +0.369621003307,0.657843987867,-0.302384208499,-0.0979202429087 +0.369621003307,0.657843987867,-0.302384208499,-0.0535459759631 +0.369621003307,0.657843987867,-0.302384208499,0.0352025579281 +0.369621003307,0.657843987867,-0.302384208499,0.0795768248736 +0.369621003307,0.657843987867,-0.302384208499,0.123951091819 +0.369621003307,0.657843987867,-0.302384208499,0.21269962571 +0.369621003307,0.657843987867,-0.302384208499,0.257073892656 +0.369621003307,0.657843987867,-0.302384208499,0.301448159602 +0.369621003307,0.657843987867,-0.302384208499,0.345822426547 +0.369621003307,0.657843987867,-0.302384208499,0.346266169217 +0.369621003307,0.657843987867,-0.277311877591,-0.452914378473 +0.369621003307,0.657843987867,-0.277311877591,-0.364165844582 +0.369621003307,0.657843987867,-0.277311877591,-0.319791577637 +0.369621003307,0.657843987867,-0.277311877591,-0.275417310691 +0.369621003307,0.657843987867,-0.277311877591,-0.1866687768 +0.369621003307,0.657843987867,-0.277311877591,-0.142294509854 +0.369621003307,0.657843987867,-0.277311877591,-0.0979202429087 +0.369621003307,0.657843987867,-0.277311877591,-0.0535459759631 +0.369621003307,0.657843987867,-0.277311877591,0.0352025579281 +0.369621003307,0.657843987867,-0.277311877591,0.0795768248736 +0.369621003307,0.657843987867,-0.277311877591,0.123951091819 +0.369621003307,0.657843987867,-0.277311877591,0.21269962571 +0.369621003307,0.657843987867,-0.277311877591,0.257073892656 +0.369621003307,0.657843987867,-0.277311877591,0.301448159602 +0.369621003307,0.657843987867,-0.277311877591,0.345822426547 +0.369621003307,0.657843987867,-0.277311877591,0.346266169217 +0.369621003307,0.657843987867,-0.227167215775,-0.452914378473 +0.369621003307,0.657843987867,-0.227167215775,-0.364165844582 +0.369621003307,0.657843987867,-0.227167215775,-0.319791577637 +0.369621003307,0.657843987867,-0.227167215775,-0.275417310691 +0.369621003307,0.657843987867,-0.227167215775,-0.1866687768 +0.369621003307,0.657843987867,-0.227167215775,-0.142294509854 +0.369621003307,0.657843987867,-0.227167215775,-0.0979202429087 +0.369621003307,0.657843987867,-0.227167215775,-0.0535459759631 +0.369621003307,0.657843987867,-0.227167215775,0.123951091819 +0.369621003307,0.657843987867,-0.227167215775,0.301448159602 +0.369621003307,0.657843987867,-0.227167215775,0.346266169217 +0.369621003307,0.657843987867,-0.126877892144,-0.452914378473 +0.369621003307,0.657843987867,-0.126877892144,-0.364165844582 +0.369621003307,0.657843987867,-0.126877892144,-0.319791577637 +0.369621003307,0.657843987867,-0.126877892144,-0.275417310691 +0.369621003307,0.657843987867,-0.126877892144,-0.142294509854 +0.369621003307,0.657843987867,-0.126877892144,-0.0535459759631 +0.369621003307,0.657843987867,-0.126877892144,0.0352025579281 +0.369621003307,0.657843987867,-0.126877892144,0.345822426547 +0.369621003307,0.657843987867,0.0737007551197,-0.452914378473 +0.369621003307,0.657843987867,0.0737007551197,-0.1866687768 +0.369621003307,0.657843987867,0.0737007551197,0.345822426547 diff --git a/toms1012/samplep.f90 b/toms1012/samplep.f90 new file mode 100644 index 0000000..f253260 --- /dev/null +++ b/toms1012/samplep.f90 @@ -0,0 +1,155 @@ +PROGRAM SAMPLE_MAIN_P +! Driver code that reads a set P of data points from a file and computes +! the containing simplices and interpolation weights for a set Q of +! user-specified interpolation points using DELAUNAYSPARSEP. If response +! values are provided, the interpolant f_{DT}(q) is also computed for all +! q \in Q. +! +! Usage: ./samplep $(filepath) +! +! where $(filepath) is the relative or absolute path to the input file, +! formatted as follows. +! +! D,N,M,IR +! [Data/training points] +! [Response/function values] +! [Interpolation points] +! +! where +! D is the dimension of problem, +! N is the number of data/training points (contained in lines 2 -- N+1), +! M is the number of interpolation points (contained in lines 2N+2 -- 2N+1+M), +! IR is the dimension of the output f(x) (the corresponding f(p) for p \in P +! are stored in lines N+2 -- 2N+1). +! +! If IR = 0, then no interpolation will be done (and the M interpolation points +! are stored in lines N+2 -- N+1+M). +! +! A sample input file with D=2, N=43, M=101, IR=1 is provided by +! sample_input2d.dat. +! A sample input file with D=4, N=432, M=432, IR=1 is provided by +! sample_input4d.dat. +! +! Last Update: March, 2020 +! Primary Author: Tyler Chang +USE DELSPARSE_MOD +USE OMP_LIB +IMPLICIT NONE + +! Declare arguments and local data. +! Problem dimensions. +INTEGER :: D ! Problem dimension. +INTEGER :: N ! Number of data points. +INTEGER :: M ! Number of interpolation points. +INTEGER :: IR ! Response values (i.e., the dimension of the output). +! DELAUNAYSPARSE argument arrays. +REAL(KIND=R8), ALLOCATABLE :: PTS(:,:) ! The input data points. +REAL(KIND=R8), ALLOCATABLE :: Q(:,:) ! The interpolation points. +REAL(KIND=R8), ALLOCATABLE :: WEIGHTS(:,:) ! The interpolation weights. +INTEGER, ALLOCATABLE :: SIMPS(:,:) ! The indices of the simplex vertices. +INTEGER, ALLOCATABLE :: IERR(:) ! Array of integer error flags. +! Optional argument arrays. +REAL(KIND=R8), ALLOCATABLE :: INTERP_IN(:,:) ! Response value array. +REAL(KIND=R8), ALLOCATABLE :: INTERP_OUT(:,:) ! Output array for f_DT(q). +REAL(KIND=R8), ALLOCATABLE :: RNORM(:) ! Array of extrapolation residuals. +! Local variables. +INTEGER :: I ! Loop index/temp value. +REAL(KIND=R8) :: TICK ! The current clock time/total walltime. +CHARACTER(LEN=80) :: FILEPATH ! Input filepath. + +! Open the file path $(filepath), and get the metadata from the +! first line (D, N, M, and IR). +CALL GET_COMMAND_ARGUMENT(1, FILEPATH) +OPEN(1, FILE=TRIM(FILEPATH)) +READ(1, *) D, N, M, IR +IF(D .LE. 0 .OR. N .LE. 0 .OR. M .LE. 0) THEN + WRITE(*,*) "Illegal input dimensions in input file, line 1."; STOP +END IF + +! Allocate all necessarry arrays. +ALLOCATE(PTS(D,N), WEIGHTS(D+1,M), Q(D,M), SIMPS(D+1,M), IERR(M), & + & RNORM(M), STAT=I) +IF(I .NE. 0) THEN + WRITE(*,*) "Memory allocation error."; STOP +END IF + +! Read the input data/training points into PTS. +DO I = 1, N + READ(1, *) PTS(:, I) +END DO +! Check if there are any response values. +IF (IR > 0) THEN + ! If so, allocate INTERP_IN and INTERP_OUT. + ALLOCATE(INTERP_IN(IR,N), INTERP_OUT(IR,M), STAT=I) + IF(I .NE. 0) THEN + WRITE(*,*) "Memory allocation error."; STOP + END IF + ! Then, read the response values into INTERP_IN. + DO I = 1, N + READ(1, *) INTERP_IN(:,I) + END DO +END IF +! Read the interpolation points into Q. +DO I = 1, M + READ(1, *) Q(:, I) +END DO +CLOSE(1) + +! Compute the interpolation results and time. +! If response values are provided, compute the outputs f_{DT}(q). +IF (IR > 0) THEN + TICK = OMP_GET_WTIME() + ! Call DELAUNAYSPARSEP with INTERP_IN and INTERP_OUT. + CALL DELAUNAYSPARSEP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + ! Optional argument list. + & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT, & + & EPS=SQRT(EPSILON(0.0_R8)), EXTRAP=0.1_R8, RNORM=RNORM, & + & IBUDGET = 50000, CHAIN=.FALSE., EXACT=.TRUE., PMODE=1) + TICK = OMP_GET_WTIME() - TICK +! Otherwise, just compute the simplices and weights. +ELSE + TICK = OMP_GET_WTIME() + ! Call DELAUNAYSPARSEP without INTERP_IN and INTERP_OUT. + CALL DELAUNAYSPARSEP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + ! Optional argument list. Note that INTERP_IN and INTERP_OUT + ! have been excluded. + & EPS=SQRT(EPSILON(0.0_R8)), EXTRAP=0.1_R8, RNORM=RNORM, & + & IBUDGET = 50000, CHAIN=.FALSE., EXACT=.TRUE., PMODE=1) + TICK = OMP_GET_WTIME() - TICK + +END IF + +! Display the results of the interpolation. +DO I = 1, M + IF(IERR(I) .EQ. 0) THEN + WRITE(*,10) 'Interpolation point: ', Q(:,I) + WRITE(*,11) 'Simplex: ', SIMPS(:,I) + WRITE(*,10) 'Weights: ', WEIGHTS(:,I) + IF (IR > 0) THEN + WRITE(*,12) 'f(x) = ', INTERP_OUT(:,I) + END IF + ELSE IF(IERR(I) .EQ. 1) THEN + WRITE(*,10) 'Extrapolation point: ', Q(:,I) + WRITE(*,11) 'Simplex: ', SIMPS(:,I) + WRITE(*,10) 'Weights: ', WEIGHTS(:,I) + IF (IR > 0) THEN + WRITE(*,12) 'f(x) = ', INTERP_OUT(:,I) + END IF + WRITE(*,13) 'Residual: ', RNORM(I) + ELSE IF(IERR(I) .EQ. 2) THEN + WRITE(*,10) 'Extrapolation point: ', Q(:,I) + WRITE(*,13) 'Residual: ', RNORM(I) + ELSE + WRITE(*,14) 'Error at point ', I, '. IERR(I) = ', IERR(I) + END IF +END DO +! Print the timing data. +WRITE(*,15) M, ' points interpolated in ', TICK, ' seconds.' +10 FORMAT(1X,A,/,(1X,5ES15.7)) +11 FORMAT(1X,A,/,(10I7)) +12 FORMAT(1X,A,4ES15.7,/,(1X,5ES15.7)) +13 FORMAT(1X,A,ES16.8) +14 FORMAT(1X,A,I7,A,I2) +15 FORMAT(/,I7,A,ES16.8,A,/) + +END PROGRAM SAMPLE_MAIN_P diff --git a/toms1012/samples.f90 b/toms1012/samples.f90 new file mode 100644 index 0000000..255bf1f --- /dev/null +++ b/toms1012/samples.f90 @@ -0,0 +1,155 @@ +PROGRAM SAMPLE_MAIN_S +! Driver code that reads a set P of data points from a file and computes +! the containing simplices and interpolation weights for a set Q of +! user-specified interpolation points using DELAUNAYSPARSES. If response +! values are provided, the interpolant f_{DT}(q) is also computed for all +! q \in Q. +! +! Usage: ./samples $(filepath) +! +! where $(filepath) is the relative or absolute path to the input file, +! formatted as follows. +! +! D,N,M,IR +! [Data/training points] +! [Response/function values] +! [Interpolation points] +! +! where +! D is the dimension of problem, +! N is the number of data/training points (contained in lines 2 -- N+1), +! M is the number of interpolation points (contained in lines 2N+2 -- 2N+1+M), +! IR is the dimension of the output f(x) (the corresponding f(p) for p \in P +! are stored in lines N+2 -- 2N+1). +! +! If IR = 0, then no interpolation will be done (and the M interpolation points +! are stored in lines N+2 -- N+1+M). +! +! A sample input file with D=2, N=43, M=101, IR=1 is provided by +! sample_input2d.dat. +! A sample input file with D=4, N=432, M=432, IR=1 is provided by +! sample_input4d.dat. +! +! Last Update: March, 2020 +! Primary Author: Tyler Chang +USE DELSPARSE_MOD +USE OMP_LIB +IMPLICIT NONE + +! Declare arguments and local data. +! Problem dimensions. +INTEGER :: D ! Problem dimension. +INTEGER :: N ! Number of data points. +INTEGER :: M ! Number of interpolation points. +INTEGER :: IR ! Response values (i.e., the dimension of the output). +! DELAUNAYSPARSE argument arrays. +REAL(KIND=R8), ALLOCATABLE :: PTS(:,:) ! The input data points. +REAL(KIND=R8), ALLOCATABLE :: Q(:,:) ! The interpolation points. +REAL(KIND=R8), ALLOCATABLE :: WEIGHTS(:,:) ! The interpolation weights. +INTEGER, ALLOCATABLE :: SIMPS(:,:) ! The indices of the simplex vertices. +INTEGER, ALLOCATABLE :: IERR(:) ! Array of integer error flags. +! Optional argument arrays. +REAL(KIND=R8), ALLOCATABLE :: INTERP_IN(:,:) ! Response value array. +REAL(KIND=R8), ALLOCATABLE :: INTERP_OUT(:,:) ! Output array for f_DT(q). +REAL(KIND=R8), ALLOCATABLE :: RNORM(:) ! Array of extrapolation residuals. +! Local variables. +INTEGER :: I ! Loop index/temp value. +REAL(KIND=R8) :: TICK ! The current clock time/total walltime. +CHARACTER(LEN=80) :: FILEPATH ! Input filepath. + +! Open the file path $(filepath), and get the metadata from the +! first line (D, N, M, and IR). +CALL GET_COMMAND_ARGUMENT(1, FILEPATH) +OPEN(1, FILE=TRIM(FILEPATH)) +READ(1, *) D, N, M, IR +IF(D .LE. 0 .OR. N .LE. 0 .OR. M .LE. 0) THEN + WRITE(*,*) "Illegal input dimensions in input file, line 1."; STOP +END IF + +! Allocate all necessarry arrays. +ALLOCATE(PTS(D,N), WEIGHTS(D+1,M), Q(D,M), SIMPS(D+1,M), IERR(M), & + & RNORM(M), STAT=I) +IF(I .NE. 0) THEN + WRITE(*,*) "Memory allocation error."; STOP +END IF + +! Read the input data/training points into PTS. +DO I = 1, N + READ(1, *) PTS(:, I) +END DO +! Check if there are any response values. +IF (IR > 0) THEN + ! If so, allocate INTERP_IN and INTERP_OUT. + ALLOCATE(INTERP_IN(IR,N), INTERP_OUT(IR,M), STAT=I) + IF(I .NE. 0) THEN + WRITE(*,*) "Memory allocation error."; STOP + END IF + ! Then, read the response values into INTERP_IN. + DO I = 1, N + READ(1, *) INTERP_IN(:,I) + END DO +END IF +! Read the interpolation points into Q. +DO I = 1, M + READ(1, *) Q(:, I) +END DO +CLOSE(1) + +! Compute the interpolation results and time. +! If response values are provided, compute the outputs f_{DT}(q). +IF (IR > 0) THEN + TICK = OMP_GET_WTIME() + ! Call DELAUNAYSPARSES with INTERP_IN and INTERP_OUT. + CALL DELAUNAYSPARSES(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + ! Optional argument list. + & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT, & + & EPS=SQRT(EPSILON(0.0_R8)), EXTRAP=0.1_R8, RNORM=RNORM, & + & IBUDGET = 50000, CHAIN=.FALSE., EXACT=.TRUE.) + TICK = OMP_GET_WTIME() - TICK +! Otherwise, just compute the simplices and weights. +ELSE + TICK = OMP_GET_WTIME() + ! Call DELAUNAYSPARSES without INTERP_IN and INTERP_OUT. + CALL DELAUNAYSPARSES(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + ! Optional argument list. Note that INTERP_IN and INTERP_OUT + ! have been excluded. + & EPS=SQRT(EPSILON(0.0_R8)), EXTRAP=0.1_R8, RNORM=RNORM, & + & IBUDGET = 50000, CHAIN=.FALSE., EXACT=.TRUE.) + TICK = OMP_GET_WTIME() - TICK + +END IF + +! Display the results of the interpolation. +DO I = 1, M + IF(IERR(I) .EQ. 0) THEN + WRITE(*,10) 'Interpolation point: ', Q(:,I) + WRITE(*,11) 'Simplex: ', SIMPS(:,I) + WRITE(*,10) 'Weights: ', WEIGHTS(:,I) + IF (IR > 0) THEN + WRITE(*,12) 'f(x) = ', INTERP_OUT(:,I) + END IF + ELSE IF(IERR(I) .EQ. 1) THEN + WRITE(*,10) 'Extrapolation point: ', Q(:,I) + WRITE(*,11) 'Simplex: ', SIMPS(:,I) + WRITE(*,10) 'Weights: ', WEIGHTS(:,I) + IF (IR > 0) THEN + WRITE(*,12) 'f(x) = ', INTERP_OUT(:,I) + END IF + WRITE(*,13) 'Residual: ', RNORM(I) + ELSE IF(IERR(I) .EQ. 2) THEN + WRITE(*,10) 'Extrapolation point: ', Q(:,I) + WRITE(*,13) 'Residual: ', RNORM(I) + ELSE + WRITE(*,14) 'Error at point ', I, '. IERR(I) = ', IERR(I) + END IF +END DO +! Print the timing data. +WRITE(*,15) M, ' points interpolated in ', TICK, ' seconds.' +10 FORMAT(1X,A,/,(1X,5ES15.7)) +11 FORMAT(1X,A,/,(10I7)) +12 FORMAT(1X,A,4ES15.7,/,(1X,5ES15.7)) +13 FORMAT(1X,A,ES16.8) +14 FORMAT(1X,A,I7,A,I2) +15 FORMAT(/,I7,A,ES16.8,A,/) + +END PROGRAM SAMPLE_MAIN_S diff --git a/c_binding/slatec.f b/toms1012/slatec.f similarity index 100% rename from c_binding/slatec.f rename to toms1012/slatec.f diff --git a/toms1012/test_install.f90 b/toms1012/test_install.f90 new file mode 100644 index 0000000..8868896 --- /dev/null +++ b/toms1012/test_install.f90 @@ -0,0 +1,153 @@ +PROGRAM TEST_INSTALL +! Driver code that tests the installation of DELAUNAYSPARSES and +! DELAUNAYSPARSEP. To do so, a toy interpolation problem is +! computed and the results are compared to the known solution. + +! Last Update: February, 2019 +! Primary Author: Tyler Chang +USE DELSPARSE_MOD +USE OMP_LIB +IMPLICIT NONE + +! Declare data. +INTEGER :: SIMPS(3,6), IERR(6) +REAL(KIND=R8) :: EPS +REAL(KIND=R8) :: INTERP_IN(1,20), INTERP_OUT(1,6), EXPECTED_OUT(1,6), & + & PTS(2,20), PTS_TMP(2,20), Q(2,6), Q_TMP(2,6), WEIGHTS(3,6) + +EPS = SQRT(EPSILON(0.0_R8)) +PTS = TRANSPOSE( RESHAPE( (/ & + 0.10877683233208346_R8, & + 0.65747571677546268_R8, & + 0.74853271200744009_R8, & + 0.25853058969031051_R8, & + 0.38508322804628770_R8, & + 0.19855613243388937_R8, & + 0.88590610193360986_R8, & + 0.73957680789581970_R8, & + 0.46130107231752082_R8, & + 0.61044888569019906_R8, & + 0.88848755836796889_R8, & + 0.56504950910258156_R8, & + 0.63374920061262452_R8, & + 0.47642100637444385_R8, & + 0.89167673297718886_R8, & + 0.85575976312324076_R8, & + 0.36741400280848768_R8, & + 0.22540743314109113_R8, & + 0.57887702455276135_R8, & + 0.33794226559725304_R8, & + 0.76211800269757757_R8, & + 0.082963515866522064_R8, & + 0.016220459783666152_R8, & + 0.17155847087049503_R8, & + 0.12930597950925682_R8, & + 0.91552991190955113_R8, & + 0.30469899967300274_R8, & + 0.064234640774060825_R8, & + 0.67129213095523377_R8, & + 0.56860397761470494_R8, & + 0.10547481357911370_R8, & + 0.59408216854500884_R8, & + 0.90989152079869851_R8, & + 0.91232248805035077_R8, & + 0.13873375923421827_R8, & + 0.68652421762380056_R8, & + 0.53775708104383380_R8, & + 0.63512621583969442_R8, & + 0.98798019619988187_R8, & + 0.87480704030477330_R8 /), & + (/ 20, 2 /) ) ) +Q = TRANSPOSE( RESHAPE( (/ & + 0.500000000000000000_R8, & + 0.250000000000000000_R8, & + 0.250000000000000000_R8, & + 0.750000000000000000_R8, & + 0.750000000000000000_R8, & + 0.100000000000000000_R8, & + 0.500000000000000000_R8, & + 0.250000000000000000_R8, & + 0.750000000000000000_R8, & + 0.250000000000000000_R8, & + 0.750000000000000000_R8, & + 0.500000000000000000_R8 /), & + (/6, 2/) ) ) +INTERP_IN = RESHAPE( (/ & + 0.87089483502966103_R8, & + 0.74043923264198475_R8, & + 0.76475317179110625_R8, & + 0.43008906056080554_R8, & + 0.51438920755554451_R8, & + 1.1140860443434404_R8, & + 1.1906051016066126_R8, & + 0.80381144866988052_R8, & + 1.1325932032727546_R8, & + 1.1790528633049040_R8, & + 0.99396237194708259_R8, & + 1.1591316776475904_R8, & + 1.5436407214113230_R8, & + 1.3887434944247947_R8, & + 1.0304104922114070_R8, & + 1.5422839807470412_R8, & + 0.90517108385232148_R8, & + 0.86053364898078555_R8, & + 1.5668572207526432_R8, & + 1.2127493059020265_R8 /), & + (/ 1, 20 /) ) +EXPECTED_OUT = RESHAPE( (/ & + 1.00000000000000000_R8, & + 0.50000000000000000_R8, & + 1.00000000000000000_R8, & + 1.00000000000000000_R8, & + 1.50000000000000000_R8, & + 0.68862615900613189_R8 /), & + (/ 1, 6/) ) + +! Test DELAUNAYSPARSES. +PTS_TMP = PTS; Q_TMP = Q +CALL DELAUNAYSPARSES(2, 20, PTS_TMP, 6, Q_TMP, SIMPS, WEIGHTS, IERR, & + & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT) +IF(ANY(ABS(INTERP_OUT - EXPECTED_OUT) > EPS)) THEN + WRITE(*,*) "DELAUNAYSPARSES produced an incorrect result. ", & + & " The installation is not correct." + STOP +END IF + +! Test DELAUNAYSPARSEP, PMODE=1. +PTS_TMP = PTS; Q_TMP = Q +CALL OMP_SET_NUM_THREADS(4) +CALL DELAUNAYSPARSEP(2, 20, PTS_TMP, 6, Q_TMP, SIMPS, WEIGHTS, IERR, & + & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT, PMODE=1) +IF(ANY(ABS(INTERP_OUT - EXPECTED_OUT) > EPS)) THEN + WRITE(*,*) "DELAUNAYSPARSEP produced an incorrect result. ", & + & " The installation is not correct." + STOP +END IF + +! Test DELAUNAYSPARSEP, PMODE=2. +PTS_TMP = PTS; Q_TMP = Q +CALL OMP_SET_NUM_THREADS(4) +CALL DELAUNAYSPARSEP(2, 20, PTS_TMP, 6, Q_TMP, SIMPS, WEIGHTS, IERR, & + & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT, PMODE=2) +IF(ANY(ABS(INTERP_OUT - EXPECTED_OUT) > EPS)) THEN + WRITE(*,*) "DELAUNAYSPARSEP produced an incorrect result. ", & + & " The installation is not correct." + STOP +END IF + +! Test DELAUNAYSPARSEP, PMODE=3. +CALL OMP_SET_NESTED(.TRUE.) +CALL OMP_SET_NUM_THREADS(2) +PTS_TMP = PTS; Q_TMP = Q +CALL DELAUNAYSPARSEP(2, 20, PTS_TMP, 6, Q_TMP, SIMPS, WEIGHTS, IERR, & + & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT, PMODE=3) +IF(ANY(ABS(INTERP_OUT - EXPECTED_OUT) > EPS)) THEN + WRITE(*,*) "DELAUNAYSPARSEP produced an incorrect result. ", & + & " The installation is not correct." + STOP +END IF + +! If all the tests passed, then the installation is correct. +WRITE(*,*) "The installation of DELAUNAYSPARSE appears correct." + +END PROGRAM TEST_INSTALL From cc1d4ac323cac89f9be4d560c417570eae5ac02d Mon Sep 17 00:00:00 2001 From: thchang Date: Sat, 12 Mar 2022 01:03:28 -0600 Subject: [PATCH 2/8] updated USAGE type --- USAGE => USAGE.md | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename USAGE => USAGE.md (100%) diff --git a/USAGE b/USAGE.md similarity index 100% rename from USAGE rename to USAGE.md From 9a902180918262e455d11d78f9555f81919a30dc Mon Sep 17 00:00:00 2001 From: thchang Date: Sat, 12 Mar 2022 01:18:45 -0600 Subject: [PATCH 3/8] updated USAGE --- USAGE.md | 414 +++++++++++++++++++++++++++---------------------------- 1 file changed, 207 insertions(+), 207 deletions(-) diff --git a/USAGE.md b/USAGE.md index c395684..e4925e3 100644 --- a/USAGE.md +++ b/USAGE.md @@ -61,14 +61,14 @@ On input: * `D` is the dimension of the space for `PTS` and `Q`. - * N is the number of data points in PTS. + * `N` is the number of data points in `PTS`. - * PTS(1:D,1:N) is a real valued matrix with N columns, each containing the + * `PTS(1:D,1:N)` is a real valued matrix with `N` columns, each containing the coordinates of a single data point in R^D. - * M is the number of interpolation points in Q. + * `M` is the number of interpolation points in `Q`. - * Q(1:D,1:M) is a real valued matrix with M columns, each containing the + * `Q(1:D,1:M)` is a real valued matrix with `M` columns, each containing the coordinates of a single interpolation point in R^D. @@ -100,56 +100,56 @@ On output: Error codes 10--28 indicate that one or more inputs contain illegal values or are incompatible with each other. - - 10 : The dimension D must be positive. - - 11 : Too few data points to construct a triangulation (i.e., N < D+1). - - 12 : No interpolation points given (i.e., M < 1). - - 13 : The first dimension of PTS does not agree with the dimension D. - - 14 : The second dimension of PTS does not agree with the number of - points N. - - 15 : The first dimension of Q does not agree with the dimension D. - - 16 : The second dimension of Q does not agree with the number of - interpolation points M. - - 17 : The first dimension of the output array SIMPS does not match the - number of vertices needed for a D-simplex (D+1). - - 18 : The second dimension of the output array SIMPS does not match the - number of interpolation points M. - - 19 : The first dimension of the output array WEIGHTS does not match the - number of vertices for a a D-simplex (D+1). - - 20 : The second dimension of the output array WEIGHTS does not match the - number of interpolation points M. - - 21 : The size of the error array IERR does not match the number of - interpolation points M. - - 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. - - 23 : The first dimension of INTERP_IN does not match the first - dimension of INTERP_OUT. - - 24 : The second dimension of INTERP_IN does not match the number of - data points PTS. - - 25 : The second dimension of INTERP_OUT does not match the number of - interpolation points M. - - 26 : The budget supplied in IBUDGET does not contain a positive + - 10 : The dimension `D` must be positive. + - 11 : Too few data points to construct a triangulation (i.e., `N < D+1`). + - 12 : No interpolation points given (i.e., `M < 1`). + - 13 : The first dimension of `PTS` does not agree with the dimension `D`. + - 14 : The second dimension of `PTS` does not agree with the number of + points `N`. + - 15 : The first dimension of `Q` does not agree with the dimension `D`. + - 16 : The second dimension of `Q` does not agree with the number of + interpolation points `M`. + - 17 : The first dimension of the output array `SIMPS` does not match the + number of vertices needed for a `D`-simplex (`D+1`). + - 18 : The second dimension of the output array `SIMPS` does not match the + number of interpolation points `M`. + - 19 : The first dimension of the output array `WEIGHTS` does not match the + number of vertices for a a `D`-simplex (`D+1`). + - 20 : The second dimension of the output array `WEIGHTS` does not match + the number of interpolation points `M`. + - 21 : The size of the error array `IERR` does not match the number of + interpolation points `M`. + - 22 : `INTERP_IN` cannot be present without `INTERP_OUT` or vice versa. + - 23 : The first dimension of `INTERP_IN` does not match the first + dimension of `INTERP_OUT`. + - 24 : The second dimension of `INTERP_IN` does not match the number of + data points `PTS`. + - 25 : The second dimension of `INTERP_OUT` does not match the number of + interpolation points `M`. + - 26 : The budget supplied in `IBUDGET` does not contain a positive integer. - - 27 : The extrapolation distance supplied in EXTRAP cannot be negative. - - 28 : The size of the RNORM output array does not match the number of - interpolation points M. + - 27 : The extrapolation distance supplied in `EXTRAP` cannot be negative. + - 28 : The size of the `RNORM` output array does not match the number of + interpolation points `M`. The errors 30, 31 typically indicate that DELAUNAYSPARSE has been given an unclean dataset. These errors can be fixed by preprocessing your data (remove duplicate points and apply PCA or other dimension reduction technique). - - 30 : Two or more points in the data set PTS are too close together with - respect to the working precision (EPS), which would result in a + - 30 : Two or more points in the data set `PTS` are too close together with + respect to the working precision (`EPS`), which would result in a numerically degenerate simplex. - - 31 : All the data points in PTS lie in some lower dimensional linear + - 31 : All the data points in `PTS` lie in some lower dimensional linear manifold (up to the working precision), and no valid triangulation exists. The error code 40 occurs when another earlier error prevented this point from ever being evaluated. - - 40 : An error caused DELAUNAYSPARSES to terminate before this value - could be computed. Note: The corresponding entries in SIMPS and - WEIGHTS may contain garbage values. + - 40 : An error caused `DELAUNAYSPARSES` to terminate before this value + could be computed. Note: The corresponding entries in `SIMPS` and + `WEIGHTS` may contain garbage values. The error code 50 corresponds to allocation of the internal WORK array. Check your systems internal memory settings and limits, in relation @@ -157,112 +157,112 @@ On output: Alg. paper for more details on DELAUNAYSPARSE's space requirements). - 50 : A memory allocation error occurred while allocating the work array - WORK. + `WORK`. The errors 60, 61 should not occur with the default settings. If one of these errors is observed, then it is likely that either the value of - the optional inputs IBUDGET or EPS has been adjusted in a way that is + the optional inputs `IBUDGET` or `EPS` has been adjusted in a way that is unwise, or there may be another issue with the problem settings, which is manifesting in an unusual way. - 60 : The budget was exceeded before the algorithm converged on this - value. If the dimension is high, try increasing IBUDGET. This - error can also be caused by a working precision EPS that is too + value. If the dimension is high, try increasing `IBUDGET`. This + error can also be caused by a working precision `EPS` that is too small for the conditioning of the problem. - 61 : A value that was judged appropriate later caused LAPACK to - encounter a singularity. Try increasing the value of EPS. + encounter a singularity. Try increasing the value of `EPS`. The errors 70--72 were caused by the DWNNLS library from SLATEC, which is only used during extrapolation. Note that there is a known issue with this library, when it is linked against included public-domain copy of BLAS/LAPACK, instead of an installed version - (i.e., -lblas -llapack). + (i.e., `-lblas` `-llapack`). - 70 : Allocation error for the extrapolation work arrays. - - 71 : The SLATEC subroutine DWNNLS failed to converge during the + - 71 : The SLATEC subroutine `DWNNLS` failed to converge during the projection of an extrapolation point onto the convex hull. - - 72 : The SLATEC subroutine DWNNLS has reported a usage error. + - 72 : The SLATEC subroutine `DWNNLS` has reported a usage error. The errors 72, 80--83 should never occur, and likely indicate a compiler bug or hardware failure. - - 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. - - 81 : The LAPACK subroutine DGETRF has reported an illegal value. - - 82 : The LAPACK subroutine DGETRS has reported an illegal value. - - 83 : The LAPACK subroutine DORMQR has reported an illegal value. + - 80 : The LAPACK subroutine `DGEQP3` has reported an illegal value. + - 81 : The LAPACK subroutine `DGETRF` has reported an illegal value. + - 82 : The LAPACK subroutine `DGETRS` has reported an illegal value. + - 83 : The LAPACK subroutine `DORMQR` has reported an illegal value. Optional arguments: - * INTERP_IN(1:IR,1:N) contains real valued response vectors for each of - the data points in PTS on input. The first dimension of INTERP_IN is + * `INTERP_IN(1:IR,1:N)` contains real valued response vectors for each of + the data points in `PTS` on input. The first dimension of `INTERP_IN` is inferred to be the dimension of these response vectors, and the - second dimension must match N. If present, the response values will - be computed for each interpolation point in Q, and stored in INTERP_OUT, - which therefore must also be present. If both INTERP_IN and INTERP_OUT + second dimension must match `N`. If present, the response values will + be computed for each interpolation point in `Q`, and stored in `INTERP_OUT`, + which therefore must also be present. If both `INTERP_IN` and `INTERP_OUT` are omitted, only the containing simplices and convex combination weights are returned. - * INTERP_OUT(1:IR,1:M) contains real valued response vectors for each - interpolation point in Q on output. The first dimension of INTERP_OUT - must match the first dimension of INTERP_IN, and the second dimension - must match M. If present, the response values at each interpolation + * `INTERP_OUT(1:IR,1:M)` contains real valued response vectors for each + interpolation point in `Q` on output. The first dimension of `INTERP_OUT` + must match the first dimension of `INTERP_IN`, and the second dimension + must match `M`. If present, the response values at each interpolation point are computed as a convex combination of the response values - (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing - that interpolation point. Therefore, if INTERP_OUT is present, then - INTERP_IN must also be present. If both are omitted, only the + (supplied in `INTERP_IN`) at the vertices of a Delaunay simplex containing + that interpolation point. Therefore, if `INTERP_OUT` is present, then + `INTERP_IN` must also be present. If both are omitted, only the simplices and convex combination weights are returned. - * EPS contains the real working precision for the problem on input. By - default, EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff - for the machine. In general, any values that differ by less than EPS - are judged as equal, and any weights that are greater than -EPS are - judged as nonnegative. EPS cannot take a value less than the default + * `EPS` contains the real working precision for the problem on input. By + default, `EPS` is assigned \sqrt{\mu} where \mu denotes the unit roundoff + for the machine. In general, any values that differ by less than `EPS` + are judged as equal, and any weights that are greater than `-EPS` are + judged as nonnegative. `EPS` cannot take a value less than the default value of \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, the default value will be used instead automatically. - * EXTRAP contains the real maximum extrapolation distance (relative to the - diameter of PTS) on input. Interpolation at a point outside the convex - hull of PTS is done by projecting that point onto the convex hull, and + * `EXTRAP` contains the real maximum extrapolation distance (relative to the + diameter of `PTS`) on input. Interpolation at a point outside the convex + hull of `PTS` is done by projecting that point onto the convex hull, and then doing normal Delaunay interpolation at that projection. - Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) - units outside the convex hull of PTS will not be done and an error code - of 2 will be returned. Note that computing the projection can be - expensive. Setting EXTRAP=0 will cause all extrapolation points to be - ignored without ever computing a projection. By default, EXTRAP=0.1 - (extrapolate by up to 10% of the diameter of PTS). - - * RNORM(1:M) contains the real unscaled projection (2-norm) distances from + Interpolation at any point in `Q` that is more than `EXTRAP * DIAMETER(PTS)` + units outside the convex hull of `PTS` will not be done and an error code + of `2` will be returned. Note that computing the projection can be + expensive. Setting `EXTRAP=0` will cause all extrapolation points to be + ignored without ever computing a projection. By default, `EXTRAP=0.1` + (extrapolate by up to 10% of the diameter of `PTS`). + + * `RNORM(1:M)` contains the real unscaled projection (2-norm) distances from any projection computations on output. If not present, these distances are still computed for each extrapolation point, but are never returned. - * IBUDGET on input contains the integer budget for performing flips while + * `IBUDGET` on input contains the integer budget for performing flips while iterating toward the simplex containing each interpolation point in - Q. This prevents DELAUNAYSPARSES from falling into an infinite loop when - an inappropriate value of EPS is given with respect to the problem - conditioning. By default, IBUDGET=50000. However, for extremely + `Q`. This prevents `DELAUNAYSPARSES` from falling into an infinite loop when + an inappropriate value of `EPS` is given with respect to the problem + conditioning. By default, `IBUDGET=50000`. However, for extremely high-dimensional problems and pathological inputs, the default value - may be insufficient. + may be insufficient. - * CHAIN is a logical input argument that determines whether a new first + * `CHAIN` is a logical input argument that determines whether a new first simplex should be constructed for each interpolation point - (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." - By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not + (`CHAIN=.FALSE.`), or whether the simplex walks should be "daisy-chained." + By default, `CHAIN=.FALSE.` Setting `CHAIN=.TRUE.` is generally not recommended, unless the size of the triangulation is relatively small or the interpolation points are known to be tightly clustered. - * EXACT is a logical input argument that determines whether the exact + * `EXACT` is a logical input argument that determines whether the exact diameter should be computed and whether a check for duplicate data - points should be performed in advance. When EXACT=.FALSE., the - diameter of PTS is approximated by twice the distance from the - barycenter of PTS to the farthest point in PTS, and no check is + points should be performed in advance. When `EXACT=.FALSE.`, the + diameter of `PTS` is approximated by twice the distance from the + barycenter of `PTS` to the farthest point in `PTS`, and no check is done to find the closest pair of points, which could result in hard - to find bugs later on. When EXACT=.TRUE., the exact diameter is + to find bugs later on. When `EXACT=.TRUE.`, the exact diameter is computed and an error is returned whenever PTS contains duplicate - values up to the precision EPS. By default EXACT=.TRUE., but setting - EXACT=.FALSE. could result in significant speedup when N is large. - It is strongly recommended that most users leave EXACT=.TRUE., as - setting EXACT=.FALSE. could result in input errors that are difficult + values up to the precision `EPS`. By default `EXACT=.TRUE.`, but setting + `EXACT=.FALSE.` could result in significant speedup when `N` is large. + It is strongly recommended that most users leave `EXACT=.TRUE.`, as + setting `EXACT=.FALSE.` could result in input errors that are difficult to identify. Also, the diameter approximation could be wrong by up to a factor of two. @@ -304,14 +304,14 @@ On input: * `D` is the dimension of the space for `PTS` and `Q`. - * N is the number of data points in PTS. + * `N` is the number of data points in `PTS`. - * PTS(1:D,1:N) is a real valued matrix with N columns, each containing the + * `PTS(1:D,1:N)` is a real valued matrix with `N` columns, each containing the coordinates of a single data point in R^D. - * M is the number of interpolation points in Q. + * `M` is the number of interpolation points in `Q`. - * Q(1:D,1:M) is a real valued matrix with M columns, each containing the + * `Q(1:D,1:M)` is a real valued matrix with `M` columns, each containing the coordinates of a single interpolation point in R^D. @@ -343,56 +343,56 @@ On output: Error codes 10--28 indicate that one or more inputs contain illegal values or are incompatible with each other. - - 10 : The dimension D must be positive. - - 11 : Too few data points to construct a triangulation (i.e., N < D+1). - - 12 : No interpolation points given (i.e., M < 1). - - 13 : The first dimension of PTS does not agree with the dimension D. - - 14 : The second dimension of PTS does not agree with the number of - points N. - - 15 : The first dimension of Q does not agree with the dimension D. - - 16 : The second dimension of Q does not agree with the number of - interpolation points M. - - 17 : The first dimension of the output array SIMPS does not match the - number of vertices needed for a D-simplex (D+1). - - 18 : The second dimension of the output array SIMPS does not match the - number of interpolation points M. - - 19 : The first dimension of the output array WEIGHTS does not match the - number of vertices for a a D-simplex (D+1). - - 20 : The second dimension of the output array WEIGHTS does not match the - number of interpolation points M. - - 21 : The size of the error array IERR does not match the number of - interpolation points M. - - 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. - - 23 : The first dimension of INTERP_IN does not match the first - dimension of INTERP_OUT. - - 24 : The second dimension of INTERP_IN does not match the number of - data points PTS. - - 25 : The second dimension of INTERP_OUT does not match the number of - interpolation points M. - - 26 : The budget supplied in IBUDGET does not contain a positive + - 10 : The dimension `D` must be positive. + - 11 : Too few data points to construct a triangulation (i.e., `N < D+1`). + - 12 : No interpolation points given (i.e., `M < 1`). + - 13 : The first dimension of `PTS` does not agree with the dimension `D`. + - 14 : The second dimension of `PTS` does not agree with the number of + points `N`. + - 15 : The first dimension of `Q` does not agree with the dimension `D`. + - 16 : The second dimension of `Q` does not agree with the number of + interpolation points `M`. + - 17 : The first dimension of the output array `SIMPS` does not match the + number of vertices needed for a `D`-simplex (`D+1`). + - 18 : The second dimension of the output array `SIMPS` does not match the + number of interpolation points `M`. + - 19 : The first dimension of the output array `WEIGHTS` does not match the + number of vertices for a a `D`-simplex (`D+1`). + - 20 : The second dimension of the output array `WEIGHTS` does not match + the number of interpolation points `M`. + - 21 : The size of the error array `IERR` does not match the number of + interpolation points `M`. + - 22 : `INTERP_IN` cannot be present without `INTERP_OUT` or vice versa. + - 23 : The first dimension of `INTERP_IN` does not match the first + dimension of `INTERP_OUT`. + - 24 : The second dimension of `INTERP_IN` does not match the number of + data points `PTS`. + - 25 : The second dimension of `INTERP_OUT` does not match the number of + interpolation points `M`. + - 26 : The budget supplied in `IBUDGET` does not contain a positive integer. - - 27 : The extrapolation distance supplied in EXTRAP cannot be negative. - - 28 : The size of the RNORM output array does not match the number of - interpolation points M. + - 27 : The extrapolation distance supplied in `EXTRAP` cannot be negative. + - 28 : The size of the `RNORM` output array does not match the number of + interpolation points `M`. The errors 30, 31 typically indicate that DELAUNAYSPARSE has been given an unclean dataset. These errors can be fixed by preprocessing your data (remove duplicate points and apply PCA or other dimension reduction technique). - - 30 : Two or more points in the data set PTS are too close together with - respect to the working precision (EPS), which would result in a + - 30 : Two or more points in the data set `PTS` are too close together with + respect to the working precision (`EPS`), which would result in a numerically degenerate simplex. - - 31 : All the data points in PTS lie in some lower dimensional linear + - 31 : All the data points in `PTS` lie in some lower dimensional linear manifold (up to the working precision), and no valid triangulation exists. The error code 40 occurs when another earlier error prevented this point from ever being evaluated. - - 40 : An error caused DELAUNAYSPARSES to terminate before this value - could be computed. Note: The corresponding entries in SIMPS and - WEIGHTS may contain garbage values. + - 40 : An error caused `DELAUNAYSPARSEP` to terminate before this value + could be computed. Note: The corresponding entries in `SIMPS` and + `WEIGHTS` may contain garbage values. The error code 50 corresponds to allocation of the internal WORK array. Check your systems internal memory settings and limits, in relation @@ -400,130 +400,130 @@ On output: Alg. paper for more details on DELAUNAYSPARSE's space requirements). - 50 : A memory allocation error occurred while allocating the work array - WORK. + `WORK`. The errors 60, 61 should not occur with the default settings. If one of these errors is observed, then it is likely that either the value of - the optional inputs IBUDGET or EPS has been adjusted in a way that is + the optional inputs `IBUDGET` or `EPS` has been adjusted in a way that is unwise, or there may be another issue with the problem settings, which is manifesting in an unusual way. - 60 : The budget was exceeded before the algorithm converged on this - value. If the dimension is high, try increasing IBUDGET. This - error can also be caused by a working precision EPS that is too + value. If the dimension is high, try increasing `IBUDGET`. This + error can also be caused by a working precision `EPS` that is too small for the conditioning of the problem. - 61 : A value that was judged appropriate later caused LAPACK to - encounter a singularity. Try increasing the value of EPS. + encounter a singularity. Try increasing the value of `EPS`. The errors 70--72 were caused by the DWNNLS library from SLATEC, which is only used during extrapolation. Note that there is a known issue with this library, when it is linked against included public-domain copy of BLAS/LAPACK, instead of an installed version - (i.e., -lblas -llapack). + (i.e., `-lblas` `-llapack`). - 70 : Allocation error for the extrapolation work arrays. - - 71 : The SLATEC subroutine DWNNLS failed to converge during the + - 71 : The SLATEC subroutine `DWNNLS` failed to converge during the projection of an extrapolation point onto the convex hull. - - 72 : The SLATEC subroutine DWNNLS has reported a usage error. + - 72 : The SLATEC subroutine `DWNNLS` has reported a usage error. The errors 72, 80--83 should never occur, and likely indicate a compiler bug or hardware failure. - - 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. - - 81 : The LAPACK subroutine DGETRF has reported an illegal value. - - 82 : The LAPACK subroutine DGETRS has reported an illegal value. - - 83 : The LAPACK subroutine DORMQR has reported an illegal value. + - 80 : The LAPACK subroutine `DGEQP3` has reported an illegal value. + - 81 : The LAPACK subroutine `DGETRF` has reported an illegal value. + - 82 : The LAPACK subroutine `DGETRS` has reported an illegal value. + - 83 : The LAPACK subroutine `DORMQR` has reported an illegal value. The error code 90 is unique to DELAUNAYSPARSEP. - - 90 : The value of PMODE is not valid. + - 90 : The value of `PMODE` is not valid. Optional arguments: - * INTERP_IN(1:IR,1:N) contains real valued response vectors for each of - the data points in PTS on input. The first dimension of INTERP_IN is + * `INTERP_IN(1:IR,1:N)` contains real valued response vectors for each of + the data points in `PTS` on input. The first dimension of `INTERP_IN` is inferred to be the dimension of these response vectors, and the - second dimension must match N. If present, the response values will - be computed for each interpolation point in Q, and stored in INTERP_OUT, - which therefore must also be present. If both INTERP_IN and INTERP_OUT + second dimension must match `N`. If present, the response values will + be computed for each interpolation point in `Q`, and stored in `INTERP_OUT`, + which therefore must also be present. If both `INTERP_IN` and `INTERP_OUT` are omitted, only the containing simplices and convex combination weights are returned. - * INTERP_OUT(1:IR,1:M) contains real valued response vectors for each - interpolation point in Q on output. The first dimension of INTERP_OUT - must match the first dimension of INTERP_IN, and the second dimension - must match M. If present, the response values at each interpolation + * `INTERP_OUT(1:IR,1:M)` contains real valued response vectors for each + interpolation point in `Q` on output. The first dimension of `INTERP_OUT` + must match the first dimension of `INTERP_IN`, and the second dimension + must match `M`. If present, the response values at each interpolation point are computed as a convex combination of the response values - (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing - that interpolation point. Therefore, if INTERP_OUT is present, then - INTERP_IN must also be present. If both are omitted, only the + (supplied in `INTERP_IN`) at the vertices of a Delaunay simplex containing + that interpolation point. Therefore, if `INTERP_OUT` is present, then + `INTERP_IN` must also be present. If both are omitted, only the simplices and convex combination weights are returned. - * EPS contains the real working precision for the problem on input. By - default, EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff - for the machine. In general, any values that differ by less than EPS - are judged as equal, and any weights that are greater than -EPS are - judged as nonnegative. EPS cannot take a value less than the default + * `EPS` contains the real working precision for the problem on input. By + default, `EPS` is assigned \sqrt{\mu} where \mu denotes the unit roundoff + for the machine. In general, any values that differ by less than `EPS` + are judged as equal, and any weights that are greater than `-EPS` are + judged as nonnegative. `EPS` cannot take a value less than the default value of \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, the default value will be used instead automatically. - * EXTRAP contains the real maximum extrapolation distance (relative to the - diameter of PTS) on input. Interpolation at a point outside the convex - hull of PTS is done by projecting that point onto the convex hull, and + * `EXTRAP` contains the real maximum extrapolation distance (relative to the + diameter of `PTS`) on input. Interpolation at a point outside the convex + hull of `PTS` is done by projecting that point onto the convex hull, and then doing normal Delaunay interpolation at that projection. - Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) - units outside the convex hull of PTS will not be done and an error code - of 2 will be returned. Note that computing the projection can be - expensive. Setting EXTRAP=0 will cause all extrapolation points to be - ignored without ever computing a projection. By default, EXTRAP=0.1 - (extrapolate by up to 10% of the diameter of PTS). - - * RNORM(1:M) contains the real unscaled projection (2-norm) distances from + Interpolation at any point in `Q` that is more than `EXTRAP * DIAMETER(PTS)` + units outside the convex hull of `PTS` will not be done and an error code + of `2` will be returned. Note that computing the projection can be + expensive. Setting `EXTRAP=0` will cause all extrapolation points to be + ignored without ever computing a projection. By default, `EXTRAP=0.1` + (extrapolate by up to 10% of the diameter of `PTS`). + + * `RNORM(1:M)` contains the real unscaled projection (2-norm) distances from any projection computations on output. If not present, these distances are still computed for each extrapolation point, but are never returned. - * IBUDGET on input contains the integer budget for performing flips while + * `IBUDGET` on input contains the integer budget for performing flips while iterating toward the simplex containing each interpolation point in - Q. This prevents DELAUNAYSPARSES from falling into an infinite loop when - an inappropriate value of EPS is given with respect to the problem - conditioning. By default, IBUDGET=50000. However, for extremely + `Q`. This prevents `DELAUNAYSPARSEP` from falling into an infinite loop when + an inappropriate value of `EPS` is given with respect to the problem + conditioning. By default, `IBUDGET=50000`. However, for extremely high-dimensional problems and pathological inputs, the default value - may be insufficient. + may be insufficient. - * CHAIN is a logical input argument that determines whether a new first + * `CHAIN` is a logical input argument that determines whether a new first simplex should be constructed for each interpolation point - (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." - By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not + (`CHAIN=.FALSE.`), or whether the simplex walks should be "daisy-chained." + By default, `CHAIN=.FALSE.` Setting `CHAIN=.TRUE.` is generally not recommended, unless the size of the triangulation is relatively small or the interpolation points are known to be tightly clustered. - * EXACT is a logical input argument that determines whether the exact + * `EXACT` is a logical input argument that determines whether the exact diameter should be computed and whether a check for duplicate data - points should be performed in advance. When EXACT=.FALSE., the - diameter of PTS is approximated by twice the distance from the - barycenter of PTS to the farthest point in PTS, and no check is + points should be performed in advance. When `EXACT=.FALSE.`, the + diameter of `PTS` is approximated by twice the distance from the + barycenter of `PTS` to the farthest point in `PTS`, and no check is done to find the closest pair of points, which could result in hard - to find bugs later on. When EXACT=.TRUE., the exact diameter is + to find bugs later on. When `EXACT=.TRUE.`, the exact diameter is computed and an error is returned whenever PTS contains duplicate - values up to the precision EPS. By default EXACT=.TRUE., but setting - EXACT=.FALSE. could result in significant speedup when N is large. - It is strongly recommended that most users leave EXACT=.TRUE., as - setting EXACT=.FALSE. could result in input errors that are difficult + values up to the precision `EPS`. By default `EXACT=.TRUE.`, but setting + `EXACT=.FALSE.` could result in significant speedup when `N` is large. + It is strongly recommended that most users leave `EXACT=.TRUE.`, as + setting `EXACT=.FALSE.` could result in input errors that are difficult to identify. Also, the diameter approximation could be wrong by up to a factor of two. - * PMODE is an integer specifying the level of parallelism to be exploited. - If PMODE = 1, then parallelism is exploited at the level of the loop - over all interpolation points (Level 1 parallelism). - If PMODE = 2, then parallelism is exploited at the level of the loops - over data points when constructing/flipping simplices (Level 2 - parallelism). - If PMODE = 3, then parallelism is exploited at both levels. Note: this - implies that the total number of threads active at any time could be up - to OMP_NUM_THREADS^2. - By default, PMODE is set to 1 if there is more than 1 interpolation - point and 2 otherwise. + * `PMODE` is an integer specifying the level of parallelism to be exploited. + - If `PMODE = 1`, then parallelism is exploited at the level of the loop + over all interpolation points (Level 1 parallelism). + - If `PMODE = 2`, then parallelism is exploited at the level of the loops + over data points when constructing/flipping simplices (Level 2 + parallelism). + - If `PMODE = 3`, then parallelism is exploited at both levels. Note: + this implies that the total number of threads active at any time could + be up to `OMP_NUM_THREADS^2`. + By default, `PMODE` is set to `1` if there is more than 1 interpolation + point and `2` otherwise. Subroutines and functions directly referenced from BLAS are @@ -545,5 +545,5 @@ comply with the Fortran 2008 standard, with all print statements and references to stderr being commented out. For a reference to `DWNNLS`, see ACM TOMS Algorithm 587 (Hanson and Haskell). The module `REAL_PRECISION` from HOMPACK90 (ACM TOMS Algorithm 777) is -used for the real data type. The `REAL_PRECISION` module, `DELAUNAYSPARSES`, +used for the real data type. The `REAL_PRECISION` module, `DELAUNAYSPARSEP`, and `DWNNLS` and its dependencies comply with the Fortran 2008 standard. From 49cb578433074bb8762de08eaf73336aabce7f72 Mon Sep 17 00:00:00 2001 From: thchang Date: Sat, 12 Mar 2022 01:19:40 -0600 Subject: [PATCH 4/8] updated USAGE type --- USAGE.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/USAGE.md b/USAGE.md index e4925e3..70102a0 100644 --- a/USAGE.md +++ b/USAGE.md @@ -434,7 +434,7 @@ On output: - 82 : The LAPACK subroutine `DGETRS` has reported an illegal value. - 83 : The LAPACK subroutine `DORMQR` has reported an illegal value. - The error code 90 is unique to DELAUNAYSPARSEP. + The error code 90 is unique to DELAUNAYSPARSEP. - 90 : The value of `PMODE` is not valid. From 52d48c07d90c1d32990ce4386bf218bae91b56a2 Mon Sep 17 00:00:00 2001 From: thchang Date: Sat, 12 Mar 2022 01:23:01 -0600 Subject: [PATCH 5/8] cleaning --- Makefile | 2 +- src/delsparsep | Bin 231136 -> 0 bytes src/delsparses | Bin 231136 -> 0 bytes 3 files changed, 1 insertion(+), 1 deletion(-) delete mode 100755 src/delsparsep delete mode 100755 src/delsparses diff --git a/Makefile b/Makefile index e8f0af6..b04dd66 100644 --- a/Makefile +++ b/Makefile @@ -100,7 +100,7 @@ bin: # Clean command clean: - cd src && rm -f *.o *.mod *.so + cd src && rm -f *.o *.mod *.so delsparses delsparsep cd src/dependencies && rm -f *.o cd extras/c_binding && rm -f *.o *.mod *.so cd extras/c_binding/dependencies && rm -f *.o diff --git a/src/delsparsep b/src/delsparsep deleted file mode 100755 index eafb2529e269134ebd9ca4e0ed5a7896a83683d1..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 231136 zcmeFa4SbzdmG6H}lR|*vlVXceQ8F5|6~Po+OlYeKB=8(Kfe0;>5ol{@DGao=B+?mq z2_y&l`0$i!33k+IW|Xm4eK1)BT)t^J(z6sX=i z_x|r^KL5*s=6Uw}+H0@1_S$Q&y`O99(Bs@(p53l4KB z`Ddckg;j2%Ud#1|U%CAqe|C>KK=RMRa@JmX-2XQ`*B$HX$v+Fr2{)DJxpI}4?)!W$ zuC6BEnHWw%p>j2Gxth3K{#hR5EC0;nQ`P9-J#qRQpLL|^mwzg+evMByU#Rz;A9et} z@i{N9FaOM!`!wYQ=l|?4?q1@|xV`=1Whll={;6@(?_-x<{MqAYe(cf( zP<_gypYq4uv*!%LN_YLbmbXMgar$jr^3Y}O?XCZwLv&1f`($`zKk+}I@wdvqc0chq z?WdkD0Dh}_TK1Dax1V^`QO>_N{$2w?Z&m+Y`)T)~{lG7Jf2(>vv!D1c?Wf%z?kE1R z{lN2gbg2A|og#eQe(K5XCw|X<;GDak`d{7;JR-2S!oyYjiJ!WkcK>xh@!R(UfA4mabUUylU}sNy}M@g$pmbY{l}0 zmp3n7)x2)ftXgu>#g{iPSv9ZWq)S&UUovm;XD?mi(%w2HU*|$qeEHHP zs}`nj2B;4kkYhbdDG%%z)*&Q_{*DB(}e{w z7cU2{GY-01xQH&i5&H2Ai&w2$ z{Eu%+22?BY#+FuGzHrH^RV!A#RZ~sN7Oz^|M2Fr~+p3o3%@<#`#1&n*xVfM-4K-c5 z;_`iZv!t2sG+(@8`Q`g&+;1P^P8Q~-j>W4kDy(1}*Kfe|MPzMSaoJ^ymtUwNEtf4> z-n{VQnFW>Yi>m}=cbVwz_{62FRx~E?cP#GZMTkRQ*?2_YtdRqvx}RciRFuhGBW0CXMW< zlz7>S&qEyxRop?h@Uq1hFHbC8wPZ=+lyvIElNKI#>~S#v`1>bZyEBiiObFk{@ibJ= zR3^pDP)uBM#>~ViC!cZVyfbT0UsxpxGlBn#(7W{1f6}cLQ-tnxpuHy&C8Q&i;v5r+ z)qfNCcMyLMCQT(v_;&#RT*%dS2%#i#tEpHzTP6Qm-gEImsz^vr7+-r`S9=x7cZR^1dac87Q`Pq9-ByH3*rms{gHzB!wd3{7R2XuVI{9# z?%JhO*3W#A)`ED^MgF&@Al{X9DeDU2W7Jr}hJtuox5X886~q^=KQ{{|E_}g(t`N1g7~t6_;(k?mlwppryzb>LHv6Q;wuZ{ z^J{q}R~5v+uONR-LHzp*;{Ag7BMagi3*yTQ;ujRe|6M`+qJsDj6vQtpi2qPj+rPIl@HPhC#=zSccpC$6W8iHJyp4gk zG4M79-p0V&82GP=fj@cg-|e?OSK@~g?>nO?;b(fACyWjGZTFOHF@VQrop^dtV(h3o z{(48&@TTxGrR8>x@jL1Sg=Ol>4O#d&g=PB5^;-BN3d`h^+hpMnC@fP?uFJyjQCKFP z+&T*%rm##qxmF7wtgy@(xs?{4ps-9ixkVP<-9T8TuUw;rUsPBoom`EDpHWz*oLr@a zpHNsPoLsquA5&N+vRtW!w<|1DPA*~L`xTZ6CpWT(h@<)ymgy$9)53QuER#)c$ihEV zSf;gHuZ6#>uuM0(O&0!Fg=MnIby@hU3d>ZJTW8@fD=ZUSuGPX{R9GgP+)4{yr?5;l zxkVQKCxvCA$u(MdmBKR3|fY;SVS*Q%bJO!tYU7 zCY0Pd3m>MiOeeWk3m>eoOeVRN7M`H6OeMKR7T%pEEE7qt(ZVk(EYnD?#=_4iER#sC za=iS~b%gCF+RuK4e)-X?^4BLMekw}Ko=rqnUNJLzjTM$2>mAu{`Nc0Y{+J53UEl{# z_-%g}X`GjiCZ5eUxgQ<+_^W!%-AL)Nsn^l&pVtxm2`_#$@rQa;k2X(*)t2iWRy$~H zr*~wlD&7)5$sbt$St{>O-{S`(e&6$-^7}@M{Nz@D+n(krR4^;9pk!?4Qt!yRz2ya8 z>)d*h6D>#2_uJ+krdL0BvU!pp&OMw!_7#RTdm$iho%lY&$@6J@ynU6=T|r_DPwhD~ z?yKG02!u1X*PabJqPf4Mm+5HkJLq%m{Mvc*&+@N*ZWspkqpw#~f-`@hu41M7$(5Q+-rdP+t?o=^9c)<_8ULi*j(nok$Y^K-u{C+=ZuNb9>zZpZec|s{haA!aD zni_Z^U$?)xm2!eSpCfLqhN$c+Wsd49=H03Kt;wx^P*+iv%>su~E__2uP4=NUWzic_ zre%L*Da{q<@&N^#_GZgE9TW_{@|@WAIT9?H4RP4^m=O>TzC=TQibOd z_M1q&Yl8X+zzbp&r#6dB`5n0w+?+>js_EB$Fd&%Am9dd1$ywjK{nd2!fOpdukXrv? z-S2z4$Pb2nuWpb3@{kIYW!nJD68F~YgJ4jp@l6HydhN3*UmMMR?PZ{n26|=6jNgj!Jk#jI)W-!*5KX#v_@0ALrU;@Zq9dZODm(eMDqfXJIlI#y&5yBn4(G{=#3ofsq zC;`&Bt-B{A?o`X^>0{~OM->}*wOVL&GY#k`0M-$2Xybij{4Sc>q@tATQaKvZEUEmP zDC+>ex#Di#z3F#Xw33!R(jcmX?#6*QQQ;{?=*;z-+RPXLbdlv0NXduecE#Sy# zj*dwK&wq%kfTt%9!y1FewOvUu!6QUesS4on$K&p`%*?=X)IFm}tGkk90Fc+oZw(FVg`XPj;^_dnyJDlo)m5w( ze<-n+2pf_*Q1dea-t=!*tmByttvLpbfVDWE7X7IBH-y#ltiPvaRk4$>>aTSyBoa$U z->w)TO39mfsx^&4miKgUWkp$CcxA;D(d!T~Cg+(*I$ol};Dy?@tx3ua(WTQ>2e=vJ z{mnuuI}C`mcdG9*?n?(x0o0-QzHD{esXnRo5<$i<9em#)T3Q#}Trr7AZ~BcDr972M z;O7gJ^UnW9D%0ZhQL6%+Twx^fLiSTHA*zDriUsMSODjt1t6%n_Idl>JIWJAm$|N`> zq~=3M>89q2GN0IT|0lu&za!P?2DQRZ@9TKCQQ-aSyiX`fdAINJs~`4msxD0=?o?JW zpt#wq+a1d$Kl}7wm*uVKC01xL(DPaZQ{y!ZQ#5YrIb=5*c+VRefj?43a{?p8Ys5tL#ptO8T4= zL+AtEF%x6(O2Hf%j6=$J7X;G^;>v|tD5{cY?N60cb!K@vH7fp#I_3xGRg~8Sucm?l zu~34H((|FSWBzP3(zYc}X6MGm_d{l%1LE4B6q4EdF8Iq|C$om+>rmQ_F{OR|uTq*2 z`X)*{6bjR%_=`V{jnR<>)#t%4(Wf9DKcrvzE)S=}ODif<|ItbhgoL=iuAlXPdP6@i zDCnmRBb<|6|7Uu)xv+OrTOES_8WXk0UAy^jbnWgpckMVMfETj6UvynF9-@DxUUZ83 z7frnJMFX56mk?M~05!S{zx;6b3jRl^Mm(1p^VXin@+bQQD5H`?R7rHR&C)M=laWei zHxfO%YeGWLKgZ7z_iV2ireY=hK2C_A?G++55*!EEOD|dFCz?q0$PYqmI*Z>7JdJ*M zW5pU`{E!LIo_AMl;F*qYGz~9JO$h;hNp&)T622%q1At%j&I3X}oL8|LEpvhO5Dr{v zkS|L|SFS70JwPoe#qB&2iMHKIul)*|ZreS`+aNxSPl(t}wEWCO&P6 z?G>fUOO`U8S`JDy8YTnaxD#firdjv7nzBcMT|Yw7jjL;S>>`(zndG`7&NW6H?OL96 zuqS(y3unJV>FBIvs%@ayhuwmCM#!b!jeA(v)`suOZ1*xBcVoVR`I(hQryk4!@mvxE z4<`xgxL;SP@wfwMfqOeJNON~82GA~X6=g33lyvZ-5jb;%fAq~2Lky^2bhFbE(4eWR zL@n)w?P+lY{0VuIoszl<-dGf!#=VuT< znzC)ieQHJ1qcK?ax)@oP=owAC=>@|8UFfm5JPLkPh=Qx*dNqa`vGFmymrCxG(SY)i zt0}v9Bt`+y#3+z*A{3Zn@>fydD<>!r$x1-a1F!p_phg*D6abCsD}Mt8Un)R>ie#?= zLP@)e^o0MPk5O>wT6@c*U>_>DMxCTxp=%|0)VL zDhDW7#1j_Y_%*8d_ETnU6i!G%0wd{ZC#Y~?lasy`Y!Xh7odTJ?J` zSKn=k`*QXB$TCh5cesl0)cPNy_%8XgXFRXQ9y6v;-ywBPuIl8@m`G?X&lL1|?qx!x zC|=UAu&?Q(=__&Rq90Xgq8>*K6^wI$QT_NlS4jP;D$g9!yoI*xN(1kO>;j&-yICHx zj)yF+ea`TZj%NJ>Z!tQgA`2ao4{E`L9cgbOi|3{G4g#U+i!EV+$sAZR4_!5Z0b2`X2>@yF1*=k`aquir60|_-wCHDpK+}} zNZ#BGmcse@hw*sw8QP5weMXPJA+p=mL=4|P%sN#g5R2@0xqf7S@T@WGn??1wY}QCQ zvMrR*PK!}9<3pAo1d;G}sUD>)mfqx&baq1fEk@w}ga!h4ot?p-@JnsM4)BAwg0aBplTN zc;lL>atR3#&0Ei0(Udoe>V1$f7!$`PJ)?=gU@!~`hwiYqJQDU1+t(K$VIN931We|U z@EccC_B*+8B61D)NDB*iN z>(I^1>NCIc*1oQ8Micv=Hk5#8@vEtYdqsCL#!{g|wvXr@rOLeAe$myGy*aDqOgouY zAhO40GyQvCuR|YP@r4@wGHzzLqE#7KN4F@hCnC@PefR^vjPxV+TzrhnbZ?ac<; z3)wC`qlx!EH7=#UD0IX<&!v#)>qx(qbTCIvLeBbvEF>Jm#=DeD%I(o@0kR_JbtT(P=Tu3WQR$?R|R zy!IZMe?N16?RmB5*IrP&a7*@jt7PKsPXhTqYl}~_0GRl7qV?PmKW}!=y=#jb;skqM zlDH(1yUi_DzDh!jhg1O`wDz6^ynf%#1M^+aJ^>8*o_*e-FnhJ@O7=sf&DcKUr5R({ z*-xs!6KnR?JinmkXTMEa1!;Q+;KYJt*KlF0m#Wo|DGU1vwEFCty?X~*SJ$3Xd$zNh zr-Mh>d{~wWuS+meZB zhSI;&;rc2be%MxNp|6Sl8Yue(Oa@nf9!YPIEK82Bhx~B8q`n{CA&G`nV~Bqv>E!lw z^0$6;V$zSUoXWPtqvP{exL)+@N0SbC(JL+Pr@T~h0m7QA_4$fzM_KJe@H9U>Fs>^dwyBG4*(CO$X?{~%sj_*u zw>7F{QJb$vRD7);ywW&-?2e7(%}!m+kc8{4?zlkPJ>_pMbX{F&f@Vz%OE}PEfHfuB zMw3^6)Q=j+X7uLwUBc69{DI;=Dvz<;-}3C<0)BW_4f`j{MG4lIS^s9j^^v%0P#k>N^LEbzmBsPXBE&&t$SEyKzZt{>#V1d*}`%Fj!sy+l*` zX$a#dbwF&P7#hT-3^t4LH@9%c-pEV6S?6;(t+o8jWuL-{3 zr1F>~!%{PBY-hC+ojL}?&yD_R&y3!s>tO7xtF_b*`u(Pv*Tc4TyP(q3O2n{zPK4}e zc{E>BRdmK!n%${##<5()osJIu_usL_C+jSf*&~{drryOvlsfBf(%1#OgU2OF{nt2l zd5Oe%K+M=3BKyW{cR!iJww)S%s5P8sl4zh!I|m|y%pbkAr!b-T(Opg`V3~UMV%9Ha zqs$(^b8JjzS=KXoVKVgt2GjG|Q@=JLL7zTTo(^6xvyb|9L`8NLWz<*g&3vr5!n^(z z+6k>i@EF)jb=JFS2BOKp2T)%W}28TXwUP5A`? zVO(w114s{8>Xl9@Ndeqa@9^To5x`5m^ZIMC!5s?H`brzBM_Pu{!7F~-@AlNTJ&hgf z1$J)z=+jBs-tH%NzgUYz-Uc-m5Ar&>?!iRvL2|f#f+p**Td+amdl@?4AEd)l_88_E zV>=lz&f4SLYz*%hT>`>{!T%(Oe_6^lIO56QNUVa zoU(NFrSSPXjnALYep|JnKHm6So_T3_R~MLsvKPRMqAc(-%0M~cc9#h^SmW4O2&URz zNqU(R7$w$iciMV(>AKm)w|MQp)<$w$KU3?rtDa|MPO5s*JNKkA-ohHF6?z) zg`vhCnh@OSDn`q4SsDrk^SIQjrcy|Srgg5B08LT zUFIckO&5X=45^Ry=+%ri8qVFw# z$jMbh7D`DK_$i(EBeF5b#k-tfJg>OVSg5ze$;bYdhXD00nvdIVI;^01WUdCnN3_F~ z-no+=WdtVm^5ow9abMk*mFC@}*AKfMw;44> z6Q}-K12JhEKw8t$%zjND}S33CS8}g&s%c~OAF@cX?g5KQ{PS1 z*}4u@ao0K{38yiJHbI7%f<5f9Ket%1@- zEV`&xYWT32pxX-Ov`bI%2r=T5xjmy#rtrROXwSOd?v zFZXG-!BgRhH7p!vk;xCLQsEZ`aw`0?3Gt@ugf&3APW?+2T_?)nVKY}#@wG}($B44t z6kVsD077xU>ZR41lH9@CC)`)8?hm(4o_)_T&3YTLPk`O^YCS*TMeEgibTWD_N%w-C z+Hg`UoY?+eMi1%`Kz{NWziF%Av@6v#1(nnIhqWK@?gGyvhVHKkWTw0O0nV13$z6o{ zW2`r1wqO0(RNJdec_XyvN41*o4raa^OikalmwqU0sEX!jYO)cGW;zsTzQcFbEkv2` z`dhZ=g+$z9(}7ZMP(q%16!c5rgyxRwp_t!yau^C*}1xAa-(v+tsx zcu)?1ph(N^>@>QMGapq?s%Soj1%-f?*4g*@BPjsjC;6}r>tJ*r);G9rtV|{EJvpfO zF63E86?^4Q?g1)e-2|=7*q*ze<$&`K^}{I@l(QvBEs5#m?sU^D_|ol2CAXgzO?hPR zx`cUcpYF~6o843IlKpiUrh0Slfi{=!<=_7lJq&Df^l;Pm|2OF2K>7(i43;~3D5LxT z$LQfMD*G=)5A*%t$vjP@g4g6bY?E+!!!T@@4y#y+H_!INm2m1Z7S}Z}a(AQT-Sn&< z&AGRPTyBw`8N*L%G<(R9Oa%kxB2|T(e{G0|FPT#8)NSV3z*BRsCiqJ$8iV@Q6gj%$ zm~U4M@|F(fZ}5ZqbxPTw6mRm9O%36X;;p{=HA-0L5^k#m7&32GLs{a2`t}rDiM>4I zlce`Wyf28~eco5b@Az$I7RB$=c$a&j@|RQJM!l2~xr|6Gv0jSyhp69g+d1M-zb6&^ zE*(6a4jQ_$(-_iJbh72>C5QIETqZxjHMXaU8nQ)X8mL$A@W*>d{IoUusfWR1*wB>@ z=WhtMs6k|l6S8}%AMtMdDY~|I`*8A+Ebe9qB2M?vE zKc5b7Gjv2VUnagw$xVNvscs?0*8rdK@afSJ$I2K;eWk=A!@AX{`We^~GNTkBMmvUy z`e0W>@F+53K1><74QM;i@R z7H5OBoGDjU)$!CGKg={L6!Z*|B^A{Tl#qQh@Abh84Z&~d$R+{}!SB=It=5kq(@Vs& zQ*1o}J{yux)>c36wSNiSuRe2M%X1Bxm#&_b3fo!*aNAXz(FPb70FS05jn=)4uA#B= zvyZs0`7WmkY`yBmFe4nNgU&21)CG~+lYR3gvNKA;boQB_X^bofm2XU!t7y9pWY1-F?6%a z54%Nubjb&-uq2P|FcCy*j0MFe@)$K@*h@!~D*dKDNYU|ek~Lq?GD<>F8G-4o{V;?r z1R74^A}>>XfN)m7L6*KUh7#-GgC#s=paBh~Bans>L^QLCwPaPPU%eYn`J?jGcasYT1h3S1w+tNgupdTh+;7Vz{kB&ocwgzOX@A9Qe*$)8bP}pa6$G!)BvtgN z6_u-481Bx=Sl^;g8H999#VCp`av@<)3#B@(KZ&fW0$XlySI*Y*HFffW_{q{35hcs zYn{dEOo&IBvvpNaR@g8o>oe4^`r$QbO{47ve_`~Hj?!Oie_~o}6HY|Tlj+ceT0`*b z?C0)>V4`DAc(-Qd7qZvgCsM*EoE}O!tKW15t-X-_d$NTsgSE^v&)I0-XwT{wgO`IL zuVMFy_k(Km)y#KbFimbHQu*$sGCx`}{F(fo>G>#=;x8(n&vLp!61QOu=z~MsD_W@- zl&JZty*7jT&3;k+IzKrWHnawluFEYK5>4;>1Rf}Pz0c&KGbJS%lV}tK?A6a^mwD~W zSRR=9GdY;5ew1~~trn4&1-hyf#u?PWI|@b`NZJUM>Ci;wX;JYresToDDgg-a=#W%8 zWilj`TzVn~?$UH}5P30#1ejv-!mr-bGR)wbyaXjJm4?Lf=!xOSNSH^`1Mi=swnR zgr*z-XuYBdHXq>D3CMK>%GQ>j1E>0y4kz9~-_oJgMP_Rw7+IR~mUB>aFxmDLTNB@b zp~!i@uz<7-O=q(#LIUP)b)|TS;sS-m6T4%!ixy_Y$C48x#NO{0u`4USn|R!S%?;Lp z0PCjlF!?4y#0?wL!I19+0(fGz72J{P3V-licvfY zdUJ=G`7Rn1uSnLRv4y5#q^G~Ypyse2Jemsb!>SVRKZs96&7*7zz#ziIqi)?j*z)^a zKYV;@G%qnqIg_VxZOHi{(+t*$Erd$U1A$hT#RE<`7;Jem*G_2`f&U@*$Z%pmUDM*7 zF))vB$Elgx@CF%*QsGym_ljVCszpIV zc)QftAT!U#^M*}v;!SJx;!W-mH>JXb(x}T^mW^?iYZ^&+qY;=wk_vC=ic5*+DIw+~ zR%$;X(KcYnKpvQ$mkLi=M!aS{UKjDIDU(;9*J)Pv6sh$#4Th(b^SaW-N|#^6tJCFw zoK*vPRsJb$SuehqilTbd_#f{iF&#X!j}|X|B|Dcq1NCy=Ok{u1FD?Gw>_2W{g!%xX zB(J=`E(^&jwo}bQf+5)^YZ*z7M<+oM6db0BBd(1r0;s-QU5B6qug{qR;H{)hzc2eK zlY_8HEGLLf$#~)vWpt=g z)lp=F10z17%`d0iQ|knz*hbYFWY*YY)Zdn6d2o94(GSRh3nkxh@?YWFe^|psG`c;^%1EEI?Ht8XI)MM%KQL!x~X?i7XqM&JcF~Vya%TwPI zf@!rSG$%`a)&!{eNjS7SAqc~6jXMi~R)wOg1$v3)F4hWT1Ft$~b?Z7_>Vuynm6s`F z(6h)MnQ1)I!SH~|1;aAt|Ax%3{NQ2EqmKGsYEXxMg@w!lD>CA@J%r|`1x$AhF<7mT zW|>C4q6+cqTb&~*PS*xK+9&*3C!y|@*9cB(ra zXqzM&=2eIhzOp;ioGZ%=k=^`LLsFcl)Zw(PXD5A1T%AHVtrOI3J)&N>Hgv4AcX{}{ zv3aBtu^q2&cExpG`#XddR6=~luKFXh1T)0BnL#1}H0tH4sm#0KX@H|wd1eYbHj$JL z%i^YM!$XiX>8432rnV;9OmbjL5)6nBrHgD4plQF&B#p#|@Zzo2t?URY)IFz6vat0s zk0GegiiW6!x!aaXQ1Nk?|BsUbX(Q?gi=nm^6f+1LZ*|F1jQqH&%qU^Cvz0}Nkm=ph zdl3B5Q%Q9bYP_#(t!W?e+6QPOUl#?+D5x^&YC|q%YD%_x?f;@&$S$fuI7rUS=$-LW zUPmgO#P-2ft#SLbYK;}67h4{Wl^6!tgif_}x_LV7wE_gPVpbxR+=Ygy$+-`&rSpoh z)tmVP63}{RnOc;qP4F0WAWU3>0o!QNj}EQ+52=!~QuxrYCekkZ+>D$!r}iusL_gjP+0>qutv;HK+xa(YC4_HSPy|;qrD)OPM360i z{t(ai9P3U8f5H(fyQ)V#an#2rY5DVXw(V|~IW`4ndRxv_%wjTxEjQMNUn$lwM>py5 zre#mgM#7eEO!Unqa9wtQy56w*8TU7AvNj4RX|)FVrk_){lSS{Lu=xhH(gQIg!svh= z38UvFh>pHO9J+8dOEdACN;3>ade=mkJ&oc-SU?iVs=xlDF59g>PuiA%mum6Bt1nH3 zXH?19=1*rWIr@I@`m?pg8Fng*ADu+*(IW5qT19Sq7V_E7jReR^5z)*8q{(@cnO#h$ zez7H&FBl9uOel~A$e2>hmMF$3r2>meG0lj-xkK zy{qMyjIW{B7RC<4t40OgiAfM;#B9sr*v|Hd;d&@{y7Cla=Nx8xurmXEq5(!C2bLrF z%Q*9=JJOOukshBPwk_iEndeTz{Yumfa;3b%{-6Ap78&dL~b^jSUA~T9$|;LN|r{`{>>w0uY=5UxnC>q_S^v)Z1e)~ z$fzyjQDEM1b6}!wcDdK?Y1LA}ywj z$|X}%O&Sh zn>HgVB{6oxg_?xuSTO@>HW8b)2F>MmAdd2*vk-&*ikq~CRae?k`_B!o(Cwu?Fmsy^T8sCA&I|7;;9ft?D!u` zp2L$4=V4R@bn#3l|3Q}g*~4%r(;%9IQ_p5)2+i~!SA)GQKczMu%s9T{Cm&)ffEiU2 zX>t#<>I;Am9bQnpi}vdt7-iCZ_)g8ehjx=9rRJx8BK%ueYw?3H0NMHN*@eLAMm5oN}W>lu(!UirsN^7{aR&3ApS!ZYMTa|-wQ4I3KwN+craYZ!v!)r zOitDXw`y|A{TnU~GhWJhVt8z6P%fzNB6q`draaS+@E7!x7;4-uP&CuoFRV7FAfaj} z&4OW$4kD8$a@%#hKQ7`lL+UkI&sbsu!DN1)O&ua4=1|=D{6LW9%^*XVK_XYl0suAA z9m=gY!9M9P3>NZ4WlL2?^jV^9`akAAryNc$ARH|t?d`VA6IXZ3GIVa;yGqm|R2G#8 zF%oEO)>DU^CLYagHSss4e@3rbz*MxLuAdT(`N>BaoN1P=yNpMz_hpdj;{PO_x3&bG_sh!d2K+$p`gVn&zvQ+VHfD_ZJ0!yy zb|CK1;FwuH%<7Sc;cunuZYi|&c5@zZ?re_J%Z z2Vmc}H#u|O+x8~gFzIjkzhG}V_B+yI{_ESD9{sof6ZWPWYWc5eZ`%58$@9nms=eu7 zKVhoa|Bk)s8k%{7y=mb_&Ao@#lkzw0O{*sVReMtrHN^I&X%`66x9v^;f3Y`}eCus{ z)8Dc;&HNYaO^^SJ^t}HidsF@_0=JlRUg_HB24yzG=LePTij_K@v`lB0SYkF~Y$v#q z-~zp@4sVb`$VEG5X$$2AB+viwlxcdwH%HDu^6d{#!4*h%UW|N029>Q8SwqR}559?A zrH&&BSVd1Ff8G%vU!EzrUx(?6#=JidcWTI+=L5DqcV)#i^W~|FKFg*thqD`+?(w55 z#!inW{f2sx0wX>r0=VQ&o>Fq>Ne4ID@dbfV6+83Diw9RjK}u|m4i+tHh(4+t@8z3w z`jE6XToJiVChevA<<{>KMu@R{(=+UAxbqV7(^q?4w3n6(3fD$k(@)_|KbT@mD0tA_ z9e}%FN`5?K*6y^w?T>y?TtPc{t8kI7+kI}(O(6F^d!_d6+@9};z+8$8YUO`YkGz~Z z^_vpdIOA7kPms@FAS(dpC$g84ld+pufkl_QAj)FrSu}6<7|v(Y@|1flXKA{qxuOI> zTLHtIV(MmJSW)S<>v*mFVdhm-Wwy7p>d;tC_TM_C&0bki&fe(&Ah7Sk{$qWOmwAnC z8@%!ULMe`&&pV-v4Z{;k8mf0RMCX*U;j<-O{V0$A`jSVy_M5c(Mm5tWcx&5umoxVE zz5A>3zn)Z;V#A949P>H&lpL^A)z7fM%FV9}y!O{IL;2yP3U)x=K?jR%S8`aU=iF|s~dsTxq=$st|Hx|yNLUheD3ZNA40rr8Z^TK!B$4s(V>og zaC1l7(|d4*P-B8@=knoyzR4uWAT*19kJn=3HIEd4-~Rbl+$hP`%8jKsE$yE>-DherY;NSAooQ zRY|(~LH0h(KgSU=ZpqDw5#IY!$=>>dewnTYlJ&i*YUuBl{`!N4>f8Ig_K#@vMC3)@ z+V}IG)-c<#gZw^xHFSQ&C*yMlTj1Nd6d2&XlfIUn>FO&he6RgC(D`XmdKM=N%!_7F zJ1s-nzNvdXk^3pB@p?S_fO;7n^L6g36K($bpN;PF#9mzS`8l9)4kS3wZV8U*{XEEe zAEF;}^d1#22)}N$4%G)oT+7{NHX{Tt6dbW!Mw8?IDqIZN1r?R;ej@8rdUyM>Nst|-@;-Z#jLO_q40nmwnY3J&}8dZTUIQRznNY)1P5iPR_muq@l_(Uc*(zlg<`03A>v?c~+nJ1XzBr*rp{+j(0& z!M>e)yA!V^VaX=C@NOFcb)!b@9uT*?XWx!IncIv9N`Cwb&m+bvK$)T5&LdLGMI2oI z>4=T+?beL*3&sI@$RdBNkp<3MWs1hNa5E{6WZXt&c!NlRgiR!L*{gGg3Qt+hhLo>T z;VDSm`i(qME#fWjQyPitB8o||zLjSU&ow+N$+Fs&n#QZ_O2n4)s;z1o*{Md_dfDLJ z=?)G)q4SN|Rkuj{xF>tUS7Z$40N`G=qi*^r=d53|bJob^SR6|fPb63yoq^ZkRhv>x zFQ>!vyOJEjj(v%H40`YOmxKD7@sZ+Uo+kifM01pca5#S>LG5aDAwS0Y1$s+9Z%)5n z{UEdc&pC!&$@4WlBq~Y8o$%M`qE2(P2%-crsU!{w^EaoGud^Si4yqKJh>g7ZT)X7c zHLs(OQ&_D@uLCvZ>7s+U6=i-aez2v=6JE7ujU6dq+uS^Y;~To8GNp36623x#bK}%i zOAoU_`nx@x$fNu;ax|dMcxMdZ_R$S0Bq=jI7|+Q1?v5a`ZnRD5peIY;$rD)~T&AgI zSm_!XKiCl_xf%;m)ekee6ZFM9H1}`uIS!TzqcuQx z3EI_2BTjWC4Pn%({zOwhiUY~n>?eQXpSe#4I&RH=l}RO>|1;bf%OT@dTpHJCJ`h4+ zS99iE>YX$7owqO{geBn&U1iZU#1%Z=+5_Zc6aCYeZdz(TOaWBLV0fwb0$wZ7CF-g! z;fl{;`PL`4?eR(|MI$G+6w*LFCdOD05!}-Am4XwJ*R2X1h^BCzRA-(c zPm8#pD%l(3s8#idEQCB<@B11!Vdd_;h&?49ZrPdpIe;JnBongl`m#d~24=|==g?>z z5Th$C*Tx@GEwncZL^`nLPP4+egBD?Dp5*zD=n*>8NZIT|ppz$ES zY0;HmD$f3kW!B*!Hy)wYocntU1L#hB=!Do~ew2QI>n}Ovj2~LCCr@8E6q`Q?E*^MY zY{TAojg@g{7;r8&DD2=a2Q0bFN_Y*A12wh5%vMK816QFu#s{;kz>Mv<7T&^1B92lj ze{DE(ou=@hk~o}du6jQA6T{@hfBmvFrXu{fV1@?bau@RlmoPbOz0jMhAe8sV$RGZ( zCGrLqr%W@;OlVXky!P#WBJn40MX5KvqZOEWUCn#XI`{6Ed(-W77V(QJz3I1Za=qNF z$I*7O29@Z|2m6m(N4l8eyDP=08CA`#C5zN-$RyakQj>q?rRF()xVpp-8>{@I8!L^b zkh+6XR-!o_656(I<*I<4Hxb8-Y2~Q+)2cXZTQFYZGASg~c&_dr@I&9HW~Slpou+22 ztjSlNPeN{S1HXsu|mzc8$3hkJTuJ!(##DkCj$J5 zm2ZiMkGN{$%wGG~tQvPKDpy1WJ&gwSSaXBJ!^%o`{HkZQs%QQ+V5Nu_;Fv?|*0>Jy zjAjScT25CHkXE@SN^lSz|o$^#ef%*2+LaBwKjh5E4PLJ?g<&9CV>9mDPpcx)L~X&09wr z^V0WhB4FgmL*i=d=Sj=ri@unwZd*w^Q15EP>S?Pf+T~EQks>4v(Il71t)#NMHYqB+ zoVobc5^FoYJ?d+%F7Kd~Y^otYnro)l^4JAptUedX6Ba&ZL>e{NL8q+&(2giYzk6-$ zA~^$7f2F}cxhG-4?pEdD{A@aGDyJ^UJgl_7+)<+k%9ks)(h$^CM(e{aW|_ky`_dd! zsH^Z8genz@6=X%(dvNOl3UJv5#spSzp&25`lnVYZ9vK-ut7LF%jmw?Fsfw#Cj3r#c z8iC549VEmRuM-N#D^A3%r-CQlAj0{C3ku6)di`KHPxC}}GA zolcZ-AdTYLKi^0s%YV}@{Ky?ii=su!8+2qxQJ{it&W#!+lEZKoGiZu_Scz{s=Z&+s ze{pO~PQ4SjJ{MZBftj(rA@~zh;3#k`^^WZkEy*#5VE)9RXn={>4aQbX1<}02#)1wV z5#Z*b!)Sj{t)Zp!x=6Ix_l!(9$Vl!5>FBk@a{y3Z^?F5lRH5<&9h*qxU~LD)Clc69 z5My8p8O-%03j_;AaGxd^`4l5|qw+988_9Ky64`*}&&fJVehHsz|K;D3z09Sgv?jp% zDKBbDPora$jwQ)Xqcx*x+MLjkd_cFN7z&IWxhu>(>jCjM0+C~7>FJL`_Zw)vA(}Zw z9^OGmrSU}fGFm)6n)$lRIiQw-qmmXW*N}YGfzUl-Wt*pzkyz>yb=JFQjX>ir5QE7$ z3z4^o-Zn(dQ_%9d%gKPcAl7RL9w%`DiK%UT;Iez8b@sQZwg=FrUX+cN3ae-clNiZz zaAhf!jxG?ktt+&&hC+-%iTbOPOr3&^1==H=W+Y_%==r;`77wMiJwrbiP=M;GIzbs= zNZ|zz;xH3;i~UYqUmFl;5`=7W`A;ncT!H%@&KgPdN z(z>jQ&Xww1@G6xpvp3h%o)K#1JhPU1vhP7OtF4iqk-fu4&2+41lo(XG&7`Bj+OWv6 zUDy2r@JgaFI>DG( zq{^}B^AEYz;|l^lgIMC2W|$ytx+5S#N2|fd^#|9( zGp!B5ld0gIXFqG}GuTa8lbx>hPHUZzHQ8xRCOcg_oz_mW(`pMlt%+o(Dh)d~^0&HE z9r4ya&k8x{w0=f&KlpPt*sgA8aN|=hp=&8B-q2Px&1>Jvs$esVF$in!%a7namPs>i z**O`xaj6b0c5OY18w)aO#cMYc0q0z44Ew~788^;!Enrb6K4Qtr8t#33$eKYAY#f~% z)FXd(JDQg)Wl@DK@evND==8&YU;QXsEj1-Oy!JCIRnQ6f=p49xH>dRG5(!h4QN25< z_xL(&sdM6EdUH5S(#vkkP|Gt=og_P6_X4i@$UF!|nQ4H))WDW{$+wGkF`Od=hkSVB+^O4WAIi@ep-r4gm_4W{tj~ zIQwxB$;lGDMQXz$>R)>U+)I8{LPs^SIPak~EdUf&-y3)U=&T3OYtzAPiv(cuaSrXT zAtw^OR9uyO72X*psX-fboe9N-oi*g3U){c{j_S5Bb##vCJ?va2c#tO+vKigymKED0 z=^3J)b$F_(J7C9E)~(tx2Mwu2)12$Hy0+JuKZFHd;omNft)9RF_c)Ah-r55x%#q7! zpeIW{sNf(kGg&Ln=<+hIW%`AaS$0YoQE?E_C8tN}gV?v2VoaW{=IVgr$=>?RX0EO1hN09}CN6MgwD1#d|q9@e}^Au9VS)%@xKou_^A#PMvBl0T~;jFylt2TeOfa zx=k83q+H@B-Gv23ozgF;vxeEx<(+Lq=(Qh1uN+n7PPD=A&Pp_5d~m{$v%n?~*#^5e zTX~(Sf0?IXjdbv8wzpO7^hmo-U_y{REzBt7x5+FphluQJ*Ep;5J>(5w8aANfjczkH zN3~{dt_>clO+H$e9I36|>P35`9f$8k0q=#E^qpIlQlcvEsO>f4I)TMY!XmymOcn^! zgkM{a7Dvn|JmcN zq0$W1$;WkFMSKedMm3Rhbi_}Xo(7dA=(OpHc~A0!i3Gb=OeWOQYV7MKG^Syrd|E+j z+fHMTxFWUfIVpOn;8%2`m0B>AzSj>hePy|=bqXiPqgJ)l_Iq@d%qG{U4Y=;sEs9DM zgT=Q@&!P^SIM54)fS{wC$FnIaR#y#^Ndq`tcDo_6lx7zUF&$Pgo91Guu~xLwyxhBstgIqh2Sj{vzTlu1=U5$cQYdgVAy~R76MI zK^DVFG;>e%PZQ9H?k!V>pj!lMH?Gc{?ACRuXigvT5-Qv@HhF{wmB(*-r~1BHL|4?& z$^%}))>dqCq9LlAs1@HtEYn*ZPpbmv&CiaTtn zql-GlEj#zQ{Tz|n3QH62g{6Pj@@t012BJDrmz(*71J}Qo9*8aT-1INtYFUmaAK2!4 z&cwfyrdS#Y?xgAb9Bvk&RolsbFY{q0$J`ktXa8~)d2pW#bLRj5oo$ zcfvY*y2f&R!U7cTWVE^J`B>Se#*_w^B+P zK5jH2LIJ7`_K23*quWGhFw91|Up`Y?JB{ z759iT{iI+jM!ehliNZEU$T$@N(T4f_iFP$Jtjbw)OGHNtN_pMrUdwq+=r!zIX?c3G zs)Gi?jIU~f&Kd`pmOFwR32bj%E1xOT8>C?sxP?j3S#HU!vN9!li%vm%%G9`5nWU;* z?gcysGQy#WL~RUYDv1j-GK=u8W+T&~Nm)eq*+aE2%W%o4)PARPg7eJZ9c6NCHF;2@ z?Yo-HUn;K=c@2!EqJ_xB)xzfn>rUiWM<(t`EUTZvdOccZJ$9Fxj4Ojx6hK|vOzo(7 z>p+Y~9Bs>%i>c@zQNM5;clsW87w|!_R8(7r+QePulC=F^`+B&>6z(>w98LUMVr(Bo zz6|Ky{Yjh+Dww3TiTD`bH=AuHhvq5lW*loZgFc#%0?Vs;NwJ{dfAlH9 zkSKYX5j&3?AEXKon|YCoZh}{Ih1Ah@%g|W2hK1?jY%Y+3!-r}c{b=g(T;kHmkZGW@ z{|#$tof{)<`s%xp!5Ne2M>KaWH`e8s?62GMd~5cx7T|cp8g=dxG9o|N9hYDz51Y!J-cnV<)n+R<(m)->}v zzCH0(D8+~&7HYUhKqe0}V8djG7mGiRT6c)IHYd&u&l#r?Uo_HotcJ030qx*?4c1)?kyJo`ad@}$Qgw6ArCotunAWy@-RP_V+Vd0p?KJ}|w4yUS_eQ)WlJ7}O* z*Tt64P}K&7-}VB#_hS>h>klCkfGYvbe6&)*FB$w|xoFMIyJ&3{N~)cU*04yRr&JxU zwyHGtoof_M4yUwhtNRFbqF)Q7EF@(J-Ks@KH1UEKjTd)8zofMc&YKNvAW>xQQJ>dt zeWr$bUi8kz`G;Hm?0qsQ;$kWh?Jxuua%a(bkSpQ?3xg!RZR~$RwCJQIHm04FWZ{AU zSVNImeAeEjGVAK2v$zO$ySMh8a40Q~Du?7`kvKM*U(yhrUse}%IG*U)U=?&2H)5Y| zU^5rWH#ylcqE3g=MnbFzL1Gn|5tV8bQR(*UV}41;lNGYEirw!MaB0H0U%HQ!tYwwE zuax{4G5PhSbGR@$d4$QyRP`hK%E=E4_gfH?9}>#z?q%hKr&V4~_Bc6d*0ee&O1#Vk zPEHEqx-jmuP0H~p2cg_?D9qSpXnh9c^fCftn;OAbfiQLAcFgX;%C@|KSnZHl70b#; zW7#n{eA?J?7Yw%u%;@FT>*Jv%@i^6#lb1$B0cOu?nsNi(DAfmvVy5gBQ_98U_aIec zY&U4JB;%E>BbAR1eNCSgi)Ouxn~X#?(V=@pS<%$j>@oLs`|6k-wQ!%Vv-=hhITIfs zrFMQ}_SLg+FXB6i!uJ^0YU<-RxCJ481Ni{vpwC?FfIlB<*-%-;TO!Dg{sErB* z_v1CQ?HN2QiuaD+%mWz~ttK?b4YlC;Jm|9w)jd$$gK}70y9RN<@l3v(+`WdoaTD$) z{nt$Mrw^r~D<2)@Dj`Ru<69Gq|B$Oq@>ib<@=HJ+-&);i;mB-y{g07m1PM2)M z$MilVTy4pq*WM`vvzUkNShn3nh#oH>B&$rX&0p`(-#L8FLpN0|7?Akl?hAcUuU~eU zs8I}D9SNA`GM3v9A<|b80QWc_#&?@&`H@w|$mW02IuhgwTE34X-Uh}-6pK&P;kFk} za!(muPY0K+^QOnAJy%519#v5lCFRFAzFZl#<|cQ@C5CSica)Pcz7$6JTh)?00?p7( z8znA(kJbs~TR<`8OHd2}7cZXFA@WKULV{kkh7_%l=z-{Ye7$1#qz}|*hBPI^0g}a-U)j) zdtRSBEt-T!v%W(^hMlTtoPa++%@2?FGF-|85zjG?>2Y&pbi`~9W^kMHm9s}qkLDd- z%D$Ot(A7KA(GhmNAq3vf#PI%fwW(qliW2m#J{WRt)%{4vVcJV!5K8euRb8@F-_GSx zy|hP_@8>=jGu@`Ecc`j#wKYKDE%hajdF^=4Y5G*74Z$FmOQ-Ft4UHK!lFAZ+oxF|v+f=Q-v+jq289ak*L0OA&qy7rPgosM>BjwXKg zvI)3P&U`f{H7NkWE}Pt|vL~bBG4H!&UXxKP_14fpU9^B(hB`Ia)K@n!T36kvY2UkX z3)=KPx;R<|A0D!_>kBFIRu zgwUrLL7AYYe~_VZvWzQx-b*N!Wex0gC$~AZqKj5R+6Xjh_r)b8-SGeJgBp5E?Gm5r zbP~1ABwfu&15@PizEaL>KNg(DlCFzay0=%-hMVP~- zvNIpDR%njT5$&}{m@hac6ua1|&kdn2b}}Kt@=nm__lPVLsWS_fFjt=|D zS45Mh-0Oz(XLBd%d*Drv=Dw_f3Uw!VtLuQ4dhm?nkwjP(osx7MlnSqx30f+_MmLFV zrX{S(w`eHY^b?7|*Ro@#n;yrF_WdIeiI#fr=aZb|ki9`u8osb8Jg(!5;O;s~>gQPq z6>U`AMyMeep0Pc(Ez8!fUE4l$vebveSSzFXb2^zFce3ajwG_LkwYp34-KgTrM4Y-v ztF)LavgW-9D-c(Xvh75VaDlCK6c+=1I6UMxIf32wd{R5s?ZqEaN1TNu*yVgIMVRh@fJd4^pM5C$j zK*;=wjGAIq2cT^rmtCJeL!Y>~H9?1Ty*-0%swY$84<1H(9PV}qg7dpV+d1{7*SD&c zGDE=RTgxS44!3RR;QURbu2X6isl<-zv3GKBb+IKbRx_gVX6Z3`2LTI3Lo=^pMeoG+ zx>!w{iXC*ZLy#PKrE4fwEKT05t9KZ}P^{)g)!<^K6o8azN)Z>t22E#3C1Jr*@6vwi z>?IAWrm`)dBs?S4Ar)QU3myqgqfJ7Zr759X6dPTPZREI<4DggR0BSSs0KF%>yheLc$w` z3p+nHxa!Gt_4aG@nb)LVK7hgr@0Cv4AwuKS)}Zg5g6PrVKKKJ(;qr3xn(~{5;e;{~ zvMxt2GH(DjMAwDysSDnNiyWgDbT$gnII*{1MZ0JMJ|9xSVam`zALjKjwYYT^jhW*8gthlLI?L}Wu${2F^Ozt$asYJ&`#hGya;zcqB2>w=A+`8SjYHO|euypbnT}`Ta z;O91>a#qeQ^w}(}8yq#;&`_;D1-bSacn&bv(Bs6_M}nVea2*wD-Q=2Q9DTY zYyI9?LfvNP{FvcLc1~G5&CZF;daLz&dUl6;?qwFk7?{QcD9W<+ll5L~Q^Q%Fs`XLl z+OdC^3LlHAbda}!y5${~(0FxEpT*Bu-vxbk)8k1DZ_Wm7hBq#_JlQv%vjypUqSN&0 z`H%Tc>|6Krf4`9X4jQ@ z);^Dp_>p+R{KlGwq>={khp|gB<(07SxS+egi0vF z>rnnx9}JGyzwSF-(4c`jU?-($S#ola?Ae8%6`4(}q6bi@kYv};AAqjxuAz76s|t_I zPT>ni5T^1lc#5|#wf)LxxNW9P&o+dZX;yG^4?V_YWy~&6Gp>-XpRZ9+`Eo#kB5Ht*ugJEF`0KWh8+%O6)2WExn<*-qcr-v!SY2_J4H+(` z9<_wn=+Fa5G($!yVW#54EqqB5vxS=B0MV?8MAe?tn0@bwx*X&Ec_Tj5!BO13-&87G zLLy)qX%55jb)ti-ry`IVoj{Vs41x5Hg(8Ta5@ubO?7QT3NF0)1xWFk1oNmn95N3TG zI3RfAO{QDrWa+!f$r#KD)9brPHvK}AYN4*UL@3j0Q1Aw|0*cejOr{c-sbvE>@+wAx@)Wdrmn_pLPw-ah59BK2 zq4tCuzM&=5sGhx=2kJqIG7OUeI@XZEDZSJZ6FM2DQAA8bed04^cO2#Jhs7V#^+D*IHw@w)I5a*icG|Fj6Ocbut}+o)Nay#UaaWMFpJMx!W(7*P~bpv+rqXBuJyjF;K@K7(CQ zFyEKaJf=Wq#43h1_Fao+-YZJQ6;2pz;4u97=UfC6j&nABMs){Fpo{7O`kufX9+enI z`I&_0)dPq^Zl~jmo2j;Yli6>aPsyTN6QaDL&P8A&J^MC+-LeB`Xn-Lgvn4)59XsSrP+_soD&pd-5OCO-x23Y;7y&VN7yM= z8?%E^vZ&J{>>$`8^GwX^1(9fujxeLCC8ki302Av1*emKHFRyc3M z4vu$CF6=W|YI$Q6G4MZldmH$;t1ACLlT0DS)^92W3ZhmWHI*VM7R}fe6Bu9yCJ>}Z z&pQwO~<@uHwqNxOCTobr&>gX%mXHDFqsy%kzARV0dhJ zD!=#V-20tO+Tz3hAM%3E_j|wh;oNi2J@?#m&OO)kn?Ma@YQs9qY`6ZoHT8X8RsUzb z{T1P9{4@MmI6Br;lj`j7?1|Oq$If`y5Y4f-F5pq~r9yDy zZ8inlSeLb37&nAYJ2)!db5V7=H{L@}B|K^?+g@b+T*Y^&uAuWaGw@l#jP@jd>_&Y6 z6;p-0KvazFJCf+QKpXe-f`iz~wqQ5x*7XMtpxidwy6ddq=C)7Kf`L)h!~uS5)aJ#p5uzJSRa!B~FLFCCcdH3-|6h~Z>K2XYtgARs2&w%OKYt0S zeT}JGMrz;2A;c5VpCPrYXs(RZE<8(e_8Pbqd*jZx$44iLpT`*jBef*F!aOPQE)h8v2a4c?sT zLnx!o?E(W@9Z`Gg*uG-q!1I@@CuzewS|F*4<}%#9%0&$${uVDzm9p0S{|JjxJyO`L zZz|ka{Sp@uk!{-RC~~!1jvuXmr`Ab#i-LV4o4n6jJoXuO$fq3-P;(B3RjAFjkAlag zJfvd}WnvGfV-GSA#O086-NpR*J$Mv8bdZ4`_6~2K3Dp&*-|5ur#TSY(jp8RZepyoQ ze!XU*F(wkZd7sU8T&y##c3R0ifz#|A&NB&58Ac{)-d#cAdk@osKOfnM{PmgCb*;+z)i^p>fQ#xn=)Yp*J{ygYxsia!O~Z~=?`RLh2T=|- z#dce6*(PkS4_kKrCZ-h6;`mey_aCxmh7A&rzJid9)bwM5(%^WG7NM6$ff&6GTcj7m zD<4oHGfYHO4d1VWVlbvkeqw~Zn@?c{*k)!Oik2O1?A7yO7}?n7Z0ugD;(Z?P7%HNq z9l;OQkL9us^ERr+*{BoM*Npd5VPUprjMul@kDQd;4IgN=p;F)2o$k9U`fn8*6N4($gV{MoH^S(0Sv- z>b;YbaH!=I4$TXwT7$6#OqV>6!ha;|UMgRWpj5t{c(vI-Imo6o8(wB+?5*pFeXjq5nF9a-e)Gsu@9y? z?+!W_nA~u^n$My~5^oJIZza)AS3K;`Q(%vrdVse_ZakhjHNM&oRLr=35-4eZ5F^`8 z4M5T=Qmm2dYiSRLi93>ppCBV#3L<@4>QRttcP3h#5eTt`ob3J!63tl~dz!Uw&$?$e z5l7y28nDkiBxeUch1fvJ0JtHVw}w2wygb*+h{= ziku6GyX%=U5{4qP$yiBWs1eO-;w&bOW-*Zmc?*G$=)fINrmedJxLcX{xLLl@2MoV8VP6ezZFeoxyDnG_8dK>Io}BCI%Zx`>)C(M z`C~y&uoacR>@=8O12se4!Vp^-N9#u5;Xf3q9{*gv;J5gYx4m%L6ON6;Fi$_rQ#-`! z=EN}>`I~LcOcW07pj@PQbKX48JkN-B)2Os_nb!CcG(<(gkYjB;fNHxnRv76)jjid~ z*mg7lvkqeH7}097($FCcKK|I!PLXdM{8)y+(~ut{u=eM%pQ^wta`5ai&kzEKdJ4l- z(CA~Ipe~!tMgxn3KLR)TAH|oxj5)Gq)&&#@4z`mSycsu?yXJH6L@TF*T1i?=mGJoVZK23+9QA4#PwwcX?^1V3HPDq~G9Yh>9blOu?xz z3e_~8E|}gAn+%QyJ4LP9wAy|Jb|5>8MQF5XiKOm)Hvs8pQmSBr>F1~TY?DU7t3?e_ zOcRr+6nAvRh7;k1|Ln6l7C;}Y@|GIF?q$waa0>=NmBXviW8(} zY1jqb-uI%Y^NvxgsEhuPw-b3RrZ?DP+L#~b;-jE=Akf$YET-4=sjTx&FT|JRF$GL2 zx5DsEGM63dTfRe9BnLB!VTgAXs6ok~Q4*bGn?#tuTuKk{OcX^%C+gHGPC!$59;}Rk z(CngaN0t-JU`wjlC#eJak?Ps&tDGiO?9aZt^L5eLx|x@s+&cZoAji(vv5WeGGykX( zc>U9ms&V&{0}EV!Hml$sXY4fVv3Bh9j2+&n*rN$=IipM2#Ndeth@2o&l$5;Tgw6+p z&PHl2J5{%y^LVA~)kqQ_47xlsS$HD1cBux3C*g3i;BqV7qYSd@% zetH;;6%!M&_KpJI{urGID*h^Hn{3!IWh=t*<0ms1_?`Gebp4M?I6m9U6ixz$W+;-a za_*9Lh|a0~M<1fo;Bl3kh79?GPOv6q^0#R-;V(b1p}xWdM=rebWp>~f5qD*7LXs=~Ax-({ zM6Gs#C$<1!&@~IKAv3qZXzq@B{cwm@%7?-@wr|EK-EmrO7h`ad0Sl*b`x`_2#)rKa z*vnZI>edo~XVhbDt%Nl=Gw7;|U4lebRhor?lr zvQGAaC-sXH^mo(&k-EnkI3fN@c&z0xzY>o|MA&=F+)FBjI*oeCzvSug3j?aw^cvw$ z|7hzrYnjc#UZYw@OOw+$s%?TaYFHM-zk7<3y{5AlUk^Kftxo*~}rmCw&(JE%1Res;v{%|<{ z-V$=?_;Xil-g(F9$BOkQ?gKd+$OCd9%ZlRuU@!bMVC)OOKO|%EwG&EJcsJt`mj8+G zxrwWa>uDu?rW@#C${-{wx82!Ws&QIk$FC5lTUc?-kEL3aQ<239l-@`_c`ovoxw8Ke z!}Bq1Cz&bI?35_EHif4?s+zkRC^5=Ypp}f~DKJs{v~<-Ss?!_>oJdf^X(#6|@HqZJ z!LnVCQx6t2dw z+J2iVp>2dLGkgK_&BA;EyoPIjCnyYQ3Qvp(i%$)mL0pwRS{+Kh$wFE82>G}bkoQ5X z@#?L|;MD_0r2p)QR5~M*RR7_jaGA>BLMYDYxeTh8VLY7>A~pFXu&WhMSg8k)n5j8= z^$MD4e>D8{J#?Wk?miqO?u-ahJ8qa^$+gS;7uufS_1=~Wrdpg6H6 z-OK!ti9|aA=VKE7n+RLizrR5{s1ldHBoSww^6_^``r7oa-E^<3TXDvB^#?x&J7(6A zeSMnj0Kc=G@4ovHXXs!9EgmAzTKSv&ptm8o?Om)qK5`moro(_@*qEwpDJJ5LdfbXF z_*OAw1yt*D!2*e2GF&|LIMT3Rs#4)&=j2iNz&=Hxyj2ng&xpf{+I+39N{%U0Jpp^l z>+NZ@dgn*=R^S|0hG$nVSnLB=`twcv_-TrH5Bt134VHVr?_!8}u+HC^F8v%hcm+Xv ziMkiu!cnO`^_md14hPK$mcOoH+Ec%IF(x{Am+3bVVq7c)^gP7rj1QR#^OVBjagP0X zHRs9f+NA@PbcVbnG>G;68O`S3e4H^Xv`xb8cTat2qg0xWe0M5Mrt9aWx|tYhG}mhd z-czMHN?aSI(qxlfrqXl)hxb-#PHA*1O^}?1oV{lAK(0b%ejPKYuX5dt_6^KbDV>xR zeI|wv&A$!9emfK1_6q5RnF_z-PRokvn1?BJ>=XqXy@{o;lYwe~Jlu%vz*5&O!tm?j z9u@2lm#CDDrOJ7u`gIX(a16)o%w1*M!v(4gPZ289pYDX#H1U&R6_9JTa5@Hy?>sEN zkofOxat9|27eD+(3XA4X)c1tK4DYNwG;zp^tDfbD%w2UDOE&jgdii;M38?U^>3dc%bzc?y+EsA6DtLmqJ2QT;?@A3wui5sek#y08 z;%93fTI3WuGBK{joo*&v(L!NCB}&M<*Qr~Kd1X4bS8czoIrsNpR8aeWjV})b4;fWzJ zOfbU@{9vhY#G=kmmLrsPykrNT|?)y=zwNsG;rn|OH|GoTAs0Q^D-J_y$UKR%4Q zc7A_;%;3;eIQ#&#KOdl^F*URahIk0e+3JJkZ_vNJ7}+Tw&`H>Frcz{wX=WI#7UP-< z3&&xXnaG|oRlzY>3qjMA>_w?Q%QC7z91ADfXmCQ3=o9TF&XJV&rHK(ePO(;4O zc3^A9ui@cL>nl3 z)gC#mnul|ybq6QRtaHw_RuciHLKBg+=b3QO@tFf{lRr!j2*pGaXE#KUt_NGYImoJZhckgWE&oQEP|c*(_w-Srb^s>qKZ?%~NHk zVlzmE7|fDBh5#PuVwjVFkNuPc=Nta~3@C(TD5D$csl zyjK3T7JNYF1x@g!XXDAl0s|FhT7wj)O3`U9uFJGys`DPUUXaDXHsyw_xb$<v?%EH`}u!H`}vlv)h&m zQ%n{gMfWvw8r1P?nMoEMZd5Pjh!?yX|2u||Z!rLRyhVnQ`~(mZZF%gE9?Ly#T}DKwqjy}u7f>;Yvq3LQsp{dBDb{?q)GOh7d{zddk(Aqyh0EB0+>vs9 ze#eeW9UFFps{=E!S0G18kQh^T?@PWdu;NA=bzRFQPKAXcep+E+9J{cyI6H0`?c))H ztJ%OfPb8#R?b$i!A)=K)OUM`4h}zuC6RDSzaD3B3Wu8b;;iQv&BTuB&WZT0NX?nD8 z-&7{$I#;BJK$N81Z1QR~+IHBV^g%Lgm4w^{(?$uo-@0=TA@|k>YLu5)>mf{n)C26z zo#iCgzpsr>DnIjb#bD?>Q(JepErNmC{4V)3g_(z;$&XZ+9XeZB;2dl?o3-6`y8Tl1 zWs|SqVDlRGLGQQ5=xc?7@Ej5N(3J5@wM>Ch&73Ae3uBTNeaaUjfAq+LI_o1}<9lo? zOw&zh7ZF}hlYE4haec&!|9(m&<1ny*#M&{%n9A$Y_r|&Wag;GE8 zC%49bEUm^SBm`z#*_fET&^m6p!~F;N+3GOL-Wlzts)%hhhqyO|-qfAmh#WQKHCe&=)o(T}=bZwzke4L=EK*@`RGk!F&!?)pndM6aW)yA2X%y=|nB>cx-W zWbG#1>{D*X6*{O4P&J9X{dOmXqlMA$4X-AApKU3T1r zHV5T)-01xFUt-T4<@5MKd^f~v3T+><9V_ZPd5?%el^JwRDld$A|B=#mtVeZ#zT~Ci zyJ*Tr_R>xujtshGQBiHh&sN=`EdaF9fTG#uO?rcF-VlqHC!&VX;+_1pmR!N??P70m zHvU+fDSytCTUO}J_NT+K6f%MFmyYJ@OFOmjaI7m(Rs#eEiy8m?R0(F~+kY%jZ2zk) zP`POV-UktqwbE_=`!0N(&3|y^r|~$<6wX2c@N#hFhs^!ZhdDh>7AT!wn@2(DPTGU& zGR*)RV1Jx7GW=}A0`(9YPMb@bZbxXxg+D43dtXTvX_{7$<8*H`3d3{(bIs>4^0HkU zK-<%2c?r33A5E&=IdLv$>}Iss$kQv_4m6|Mp9rtT(*t+EB5$V^(6~(5O!0xJsr^)v zP_JlaEo{EgQMch`hOMU9Z_bjh2xAN5Q&eB`BUGz|=8?@y${aY$cDzF@IQ^nW!Zr5_ z^S3Txim-M}ri&=1K1)iCJrdL{GN5lWjTM*uVMPDIK8@&$q`YxP^s&M6@0u#-jy2RH z%`l~-x_}5}6|RzaN*+S}X~aP}OeS%3s)3L(nJoYw?>Fh}?MaKX-hKz!YsA)*cQ||d z&^7^H>gaBst7%bv9TJM)3b!c7h><*Od5Cwe=quqC6Ws6r+|Zo6okCUSzoqQiDL5BQ z?2m>9Jrhn33~HGbdDPfG9DZ086lUFYF&dyMmbbk$&CB_M=@RCHzZ)6CcXw*>8Kt8R zH<0%K2#gORF_cx1p0aDNeqhZiw}x9k(leZe@ZoUEb2jgOHl+E-1pfvju3MKrGXTh0 z{$U!gvGGLPzI2O(j$I(vf+ZeLG~lM(vvj?MZlaKo`H7g!_$^2RVz{KQnontfT6G+8 zMq=H$ldBsG=}Hc4@k!e9bnAn%F{is8UVJvh)=v^4E86kiYU~(BvTBqcR}SgM*%1oa zVU(`}-gA+w9MS$A`6RcY$ayiC@GZQKd)fz;gUA!Fql4+vJ%Og6eAQUzNm`RML0NZy zr{Qs|RCJ01Hd*+r8B57ow&vRbGUTYaaDr6s!HksW{@j>TW<$c(kwR+!N}kQ!QJC4A z!NTKJ1jrl`rl93+YDUXd56Sye+&S;Um)cKTdVzs-WnxCokSsevaoeY4)02<|AYKO1 zh~XDteq>c9a&iu!bmH0?B)qgSc6SEO`BxgK(TT1Z44T2~PILjM2F}kv0JPa_=ete= z0xCE7N@t~IN~g!`fTZy^(xFgfHWl#GqIyavtJbOaWtx=IahCyosIvPF(5)0qw=$wZ zQOwRrFJ+9L!vvFr!7|OtsMA;4S{B!Sf*f4iXFaiNzc^hku;pcBY;1`+>>J0>zOj(I{fa%Ww7hMgO26UP$x6Wq6`wN#y}1h5_^&Rp?x`>LylFM!1fb^0%` zYN^1?Rc3`N!VLGQEfLm(>KmC4?Kgz)(BL`-j)`t_6YgcMGWb}+p{DnW zH(dEN;Dp-+8XGR2%|zyIyYaTWarvj<6R|?Ql=#Sgnxsw~j17SLf z+@l*33#ns?nz1XBd?!;_W4s}L$##_Eb=*1AaaXM4$yi&!Vo<|{#&B3IyBY&Y)$ofn-G>$cr6T;c zq>aL?pWwS&8vnhh^XbX^AoTB2gj$R`fAvw2|G@?XINa? zx{2N4@nRb~6UXD%@mNlGMOoU2KYuF0S&vm21L+M zc^`RE1FFXiw$iu{fSuC-T{Jj__Lr3E2$Z_5Vv0wP7oU{8&n)ir@bD2^4hnN{$4zPKxXfW>f)D9H&_%q9pJO4qio^ljdi<7>9|->gaWU)Gim-n8b~fd zVNQU!BWL==Ep|c>^%P+_<$fjaKeG795oY7B!MPDDE%U^4ng-xy8x-p;{`7-1hfqm^ zJ8r0XFmh_}YAa^`cQB|lL}I4~Csh~EcLn7WThYcQ&3VV-6x;Sm?+^?17!@I7FVOVH zm6W<6B(^9x#6km~{5CWCQYzYO2QrQ?Fcz7Xi_M3_V*lY9>uq^2!xQh@tNWw!;IPR1?;jz3}$f;*UjmYya}Tkaf{vBghJt&k%W+mODFU*`5L( zlM6>9YZe8=_bGqmFZtd84qi_tX&;!LqjEVSjE4UX=4WZ$a$-<;KTF!4X)Qw1U%SOz z653{o4bsS#DBOXhL_?z!|CT2AN__f0>#5sri#vmPsKK02HJ!A{77c6{bBXrV z{~`p1S&j5xf}=TPbn9~CS&d)LmGt!s-p$K8w_3n98din3xW%J+UxK=7r zM`Cp*w=11%OK^q_$>8S18uDgyUr$U<<*QSjeJjT43-~@@RKQ=#-P9+LQrtzj}Aj{&t($}(mml9<$_7#G0S~otzGSy z=4wT-b3uXwZ4=rOXh9by>c9Qg*JIni{qWb*tvhnJC+?&E+;xd{{NO!tpJI-!67M1H zcG7TAe1;!=Bdp4GiJN#%=T;^L_~l$jI@g)#RuWgW@z|%wy!y^!r;GoB)41QVGqIHP z6m}XNbjl`L>_+!&Vs08ySYZftwbg^f1DDj5$-R)tZOt#U*3M~X4Z)Su;R}+XTOVe~ z=BM)xRsmL(qVC|9If=|#i504k9I7u}b)Ai7Qz5ax-TUyOzw7PqoWy(ZArMw> zBl1NiA5XA<8Z$|w#a+<##ZTXhp*r_Rh9s4kRGdRjMvljhR3Z*@rbSRl6o^_R^RJ~e zcIVDcX#KF~2|UjL)}Zr3SRpxUySm%C%7>9Hu0EJnI~FGDQ1frh@U4c}7=*nQz?`M$ zhYoTvtcY_cuU5_CQT(?On? zVIEn}OVgyF^b=CARfL=QG%{Wq)+K5$--dxHsJ!z7=_@Mc>s zYi4~DtG{@M`<<}R7{djL>f(uPR4LbBlnAYzYvLIx^_Bt+e$5GNm)=!h(s=g%PQGuNyxgpc&55-k8t zSh-YUj@VhPlIB*Eq_PW?G+9Z_QPMoe^hnb29hhc(I9-LiF+*RRN}m;tC`T9v?zn|= z>Wj5o2q7}#>xqW8kB~ycHo5B!KiVXxL6_kj?4O%TR1?W4TeUDT$+A@^FGx%bx>Aw> z@~5C%oS>+u#OM>3(9xB2u=oKk;{DHQgrjdyq%XZwLohO88yvmEZ4f%|4KIhfai1If zZyyK0@vKa4b2Nlmf-7G7hdyn*BNkgdM%1}7(X2!!K!x7(r`M)gOjcONwTb!sW}({} zzNLFR6Kih$ttHjlGj6RPwJSaq^= zD}Qor7837gtbz%hi2;q7bPNyZdc554GrJzi=Fe})<}Yj(=bvk^9gscZ!gSLV;_%*_ zm}ihJOSIURlX2p?F|kz7N1R;8=x}2-3Q;5o1;WwNVcBQ1aMRNTyfk$^&2{uNmd!nx z-t~}**OQ#he_W5X_SjmVJ)*Uat9%nUAGJ1QA;p$#Zf&B$zH%Y=lqb{quclR?PDy;9 zn}!3-%jC}neJc}bQqceho&CZa0YY~@q&1h#Dyzt$P5HkE91v))XV+(rI2+JmigL2! zV_J31R}MmoP~dFPkp^pP6H7pSdWzLmM`1Oki?f@Az$Oh}ZnO1iS%S+x=o2v#mL-O% zgbL_Wx-P@XUY;9Nxrj->LpC8>=oMVFfnF_3R9NNLIljzjt+K2u6E)V@yKU!Z@`vE5 z*!H)&`AaLRN7#+kt~b{(wLp7&Ey_UN#4x#JOl5! zF;UbAF(Hf0AN@52sTcLW!oTae-ao^Z^g2ut{S}XYzZltbnx7^Lu25Y%B%_Y-%w+8r z$_NwOnOLolUFc5II>l3!2~vo8aIoS#{1!j%+oO$jdOvXF zeYM`J^e(^!#VS%vBf6D(D+PD)sc{Aqn+OI@5*0fL4QOst7e-HpIO3kca`hpPsdO60V%G!V)4n1y%l&o zS7c=M>bh1G+V#TXsp>~`zl~&Zv0q|sDkn>ZQD*Y~_Ge7~%I0shUS)H;ic9H=*0Cl0 zN?^18|AT)qt8fxP*B^1;un-6!X!n1s?kRAqdu#KzBtjp7@_R% zUv}!tn{1a=X1G*iQ7L7#t*;_`wKt}?+2_}!a4GA2il&WA`B$Y}dS@RTyKH4u9N}~? zdrz|j0c!Yjlp0>Xbm{*il!l)m*{`=z{@d-tPto_d{F&Z6RgdlC!jF*b^JmYR9~oEWEg#otNJCR2?ot0l zSN{Q}`k$f$P))G>Wu)1C)~~$#tY5qO68wzIPBNnX#|cJ}uMRqio^l z?33?5WwfrSO!WQdhQ87GnN6GEXS}i*)o+jBKl;7kSKbo*&$mBQ!cTQM{5GS4<*y=g zQ$HsdeEmO->c5vS`^1m(me(KNL{3fJmQhoeIsJ3xgip*(A2B;I&wZ8n5~R0r!?wE# z*28gugQKPd$52EEC%+dQ%3Fei`5jIsXEZ*9gJ$cbaXx_5^HykoCcYqU&>O!>V{D*Bkg~Wx4qgI4VT)VH!A;E_LW~_TFPHP zD*vbVm0x32%3n{5d7dI)*ab&fFku8)m|pqDS!^^yHZ z*?d%iQvad1a246h`p?^5{TFXG_=@D8M-Gw6g7gt96HEBA7o{vFF#_{AaswtOzdV>b zB8rs*jUS15`5;o2>mQ2aZePsEso&&1@!{^K(&%-1ZijTX6w}+bSs)K!6oyVs$8MEK;0^SF&&m>Sld5Fu)Uw0 zz&4Q#j*F~{VEY41c~97stpu9}w3kdHu>FR&J-`wPl*sK`eJ?D+ON1TUn{KkVwel7$ zzno9gx*Z5ZYGs70A5`9`M(InV8cprpsK&L_XoByk@&fZ9%yfLQBIrDfJ|bXq!vYyI z9WzMUYHi+bBD&g^ASf_{^czUQ2I`KWb1i%Vuc_`q?oxAH1CDWsZ%uM;lFja-r@}S( z^NgV7C%i@ZJ(tlSmqzO{zRNGHRHN%L5%P${r%La^x9@ACsyuD)Dm6BxDv#24KYNc* z^&YjK5u+PHEe_iw<0;hcdR@qRxNSdSrTq@}@Z%?rK|RrNdtx#|l~gD|$?R|YpyYm~ zkq6QFsGf@mHpb3YAC8!(k%{nl-NMQ?C2`i6Yh7OJ6kR~FQ+W&H zUgO8icV0`C#yrfx9^eo0Nw;RWcN>>QMSoF! z)^q_T>F38BTg52R747x2g~SU21oX8fYECO0{;{UQai}0xdcDFjuO2|o&}644^Hqx7 zH=CMQQu*4)4G?ns!Xu9<)fmG*_M{9Pk}hIPDx%3hw-ML=*ANXyL5q zL8yjW)@RWfH|uCDWzwi%({1lpCABzmaT3;U)H`Q`QYNGI)!A6iC+Z+x_-)By$j91M z`x%`aZaaCeX*>yxm1dlq#^EdF6Vp#!%^90#8&S;ml0(?BJ+y`|)0f;5blpiFC9k&M zwZ={Epndwy4AE~@XF_a_q1wogW$x3jC(Kg|QzvH&>FPo5^3=8Tn|1F+HZfVlV(P(~ z;;XxN)3o-Hbec^UU(=>%b1kHkHyc#JGBc_|iZ(G8bJUUj3{Az_Zak$hdn3LO5y^x5 zZ0yPO4EBF~Z!ZqsvKNvL<-;CGy7Ohn-FAA`BGs1Zro|-J`YqQroYrHu`8nmVoBxXn z5{95u5E7_f{8acQ3c@0eJio#nE=<&ikC`B|Eb*s-IIOHL&#CvLF4Ue4%^TR&d`se! zuvtcwqDW}ICDs&sB9k0y|6}-l3Enn4l`Z@~yp|qp7$D_T?#0xUP24~FHQ`{M%^l(% zU{K<~4yswFV*tOl5TOHKGBx(70RYn zkU#BWnt87F&kfNtce``Pm{d>oB%Mb#IW5JiRA8>2Q~-5`fGR%yj_B3vSPKW;`i_i9 zxLn^^eCXHGCZkj&n<^U?jFg$~0BnX)DvW5p=DoixzP&1Dc2&DN&`+(?UaIFSX zi;r|4lc(L4%406a8PI!@0#zzU2pWE+C;YqXGNA<9o(DMH6Az^ zGxIQ$g)+-+>uI}fJ^5O?aQHi#KUgWdo00@go_LrJ-8GI?RGq_c-+N83gdZdWX3EDb zlEg|1WIEo)NGU9%Aex+^{eE=tlMX3`e7oQu}NI5$S?K`m(;)z6>m9`RGbc{S;?kZo1E+>8+>j|gz zFq9;*%pk2-{y}YON-*{#FUm1% zTAJTwr3X;W@nQR=w4Xey`7QRe(Ho%dw%$yw)zZtncyZ-dlV!|GvlWNLi(JtOH&dy?KF_8LFTLV zGIX$O(fy1Cl}_e!iJmkd z10?A0yx=n_wj$Sb6E@~uIxsl`+cm6OX}FeOc3pK9Z3i@V97_<)XK7sQyhy)kcG|td z*X?Ek>y2Nbib-{@KMyQ=2ExB+7i(eR$RE5uLifUuOj7wLCD=6>WHNN@UD7K6L zo>=asOdGeBVj(e_V^wS}{({VOl1KiHc<)ht7tI6#s$ck@WQg!=cb|O~s-iyU#$Cp6 z8f*ZoUx`=2vR|;>QEiSTuk|b$W`GMrCU>8?7G*mA06#tk^1^-D@nhKZ+!9k>_Nu13 zd>&xRb2Wy>iM7TsUku#a-LTqHO0P0-<4BGPx?Up-oY=gs#g#2~xM#G45YHy>(LrcJ z%VrDb2AL@YX?p9!rRcKXSN*y$b$L!tU0m~cYQM$t$>g?WwuQ!m70ze+=OqZZSft)t zqzRYu$J03uc|E&($&)bPbBqC}>P9#wXK;-7rugC~m(By6Qke4z=3@EW`r*-xbvA~t z-iVgrWDfl>gU5X3Rfd`3VjebS{cKj+9#dDf2aKvs-BqR*8A2oI)FRLFBw}4HvIM!B zxWeNay|Z=8*Rox)eKQqDlR3D$n}DscY+>p>WMh51n&oR?DKe6(&_=?fJXVXAchlQm z)J?J)c4QFF<~@s14Y#flW{{F=3C*UGj|R)WZ16bll4;#wGtKw{GtKdW%VL)p8LXg) znG{p``bGq{#^kPr-0{8AS#;?_HK=h_^i$0i^PF)^T8yQ}h`lCG02f*l$etCD*Er9R z(p1j4j0m4uOCHUVXbuqk{!;s1qqz=6naReI#kI=vMV5 z5_PwVukDxW#I6`F0-x!55T#%Wz`dHJ(E$>~bB)Du*5 z;=Llyaol-OGc|C5j?doA70&k%&&Do2$fD@2(eA=+4bw?1X>FfUw+yb>`fN;VJV)?O#)+P%3Xk*iEVGn{hn1NHZ+Jde7gyG>;mFw zDh`Bc63$Oor0n3koW9~twF;a|0XdWGUv#%1Rll-@F?SC!J*h)oS5&SJ3p(RP14Ufs zT=CC4>|F7fOI{*x>q?IjItz-#Bl?FsJj%kmjf+g=(rNK<`DM>hbipVNU?zFzqG!Wb z*a0wnM22wc1ws*y$X&f$y)nALGvRs)u>9;2tlAxv#@7p9!q0pK0uN49n9rK#leZNC{2-9aPONLZgM?_@0&x^yzg{RDb(>)pjK zj#}^VPyEIo1^J7`!oTTP4oPKe-rVAC6tFdK?&vk|govaVJOOXz)@bII0A|SOyur+b zKy-vO%O^gIUxcl2h{4%wTe0~CtzcTyY#AH9a?Q1_K0tFr&|^_e*^Z(xaauMOa`=ah z#otU9A;m42om;}P6h zVq1Zm>)U=&dkfv4Eo#&B@8L)LRc!1MRC9;iFj_h^=2nIU67a?EIX9-K2>N!WpSf{ugba&NBHgX z%k|WY=ON}VZgt8G3l9e#SMg17uHY9o*U$e$DD|>20*4ng`rqu>cIwG$N9Elw!2 z)YYaO_u7sBI824BT@RWp=2AH3st@;*r@5e^m9>WT;@uBIOg0J4c2b})#(CN6T`*^sBC8`^cq@0ui?Fb zAX6AWkpddCdGuv2efbiJ%M6Td@^KDrj7~LeXWO)EWG36g=xx*jC47_`+54PHMy4w)kYXR&7_ky0@s%#!>hw z>zk&SY^5Qff86vj^8m3NtqybI-KK_N=7}4L@bOsR(!MoQIGzR5@hJH0_nw2mfXU{8 zXu_CWVLDeX_`@WhTY-8!;^)r=>$mg8ut&BI_$>^59!J_Sx)qQU6=XU3^` z&9hpg87c7>ICDJ!>5m+Ea4pbRQuWnR1&wmr*RS}mN{PPKm%h&QUzHMl9j10``-%rS z>3*2cp;Y~ae@`l0=eB1xbB}q7A8FfWRf31&ksLe_jY>u@m(JnkJw|e1cU%v|Q|*}f z+2~VSK=}mthue=WdNe%tRY`lk62@?~Dq|+uPOnVlSEVL5j#XvIBkTc6^_AO-9tj7r zgaz*0FRLVo*2-nGxD`FiEAl_SQVI_zzy11YdNE2({Ih51Eb`kuH|Q7n&1)ur9G7+W zHMHHr{~QLIUo29b9QNU;6lX~;pUP-MN17YaOfF4X&t9UL9o~xHPf18a%A8-)HB1&* zNNV$=DPS-z-DYh>Yj@5HsxR{7seITOc@&y4{3sFCSfCACs$*#qJ1#DRmL)e_0{SH zio{9KU5O90t~DfPa@$LjNj4(meNc+=YktMA)2*|w7L#~660Fj=nt~sO^RC#(amY9?qd}(OT$4nC}^w zPWFg)PU1jiBg8w6~$KMF9xL(tSx*7~($3SI5Y`vFl zW-mt1!K0w`V{KkmGhAm&pMnt1oH1tKqgd0@yS@=Mnkg(m%6W4Ux)ettt}HD72e?Sd zoEd>?ZDO*NI3e>Xnh-}sl82<2uw|(p$V3ki5BgzVY&ErUGPE7RS|{LTx1>d*5VwpJ zKPlCGtJ}Z|VV0i;J$k5v$&M}v9%+r76Srl}I>#*RN2*+FT?P9O?SxN{`H}4eoO%_Y zs1iiTz7<@41{09%>KyfpXIX|dWYGB7yo_WY-QR3sr~Ta9=l(N{$#Na*b1oP*dz{n* zl@OEu@WbQ@0dn1iPA|&PsP*2X>oN9pi|z?;XMAyvJ_8nFf`w4juenhU(jNLZlv&e@ zT1%W9fCaLePBEmXL!Ui$9wtf;g;gMtTbL!x=i&$+2_ws#gg%np*9(U)!N8rwJakDK>aRsUKRj zMf$!!qU8l@Q>eCnIlB&HJYf82++`7!6t8F%dHA8Bvz8rL4L@GSRUua7t2(}be7k{{ zpewX4InJQE#1RE+gYRlFYQ9bnG(6e=*6O!4ez}H8glsUHoJJ;FT?_Hu5ahJi2R|hY z?<9{c5HG2O_@=htOcd5$x$H=?QncaZ8;j6itTjBa6)4PV6sG_(1D+1vBnX8Nam5Vx zuh3p;2WRpH$H8&55==)pzLF+v8&v=Fqhgi7vYKy#N#j{ORU10$?Y5qykhR}sZlmE5 zH!Q@lrz;`v!4Hu@D>hoxRISzoRD~XZs7Al7U!cHP^`=3uZej>os7hYO((-;o2)YQx zJ%Qr=4t`j(EV*OR6E@8S4%1#!PEH)O;+4km7q!A=K9Gq4P?%Z4x+7D9R#{PItL}N) z{X4Q%4349<7P^7AfEL_07DSv2T>JjU91DKt;S_8`=YMuN^V;8>>Zkt;n8}f*kqb5 zfuX7++B2F{Sgdh(SO>{FNqIrAnXd{nuYkwDFU8Ffv8^ZM@OHE2XyFgx!Qvg2vxFCq zO`&a%Spw6J6!(`hIo^6o>&fU*cISf7`>1pDX#7Qw#3~x|mGCh$FKEG_VxxmrMK-ZI zHBdUAScq4npxrRYQ6Ykx5JPPDB^ePxEE5Z}SiXgq3!kFY7Oa$rXm=0BrQ@I-wB$$i z1Xr938K^ATlf8?c8a%MK@^s;js96eL!EWIOMq1Z_ee z@)1iGvCzj|lb?Wc;X0aVjBXR~AM+Eh$xXm$6?8t2i<0p`(IvRi9O^({yh}O@{+gIkxvg|+cQ&>of59CUxaoH-tFZ-TGF!DH z$Gb6c)zV z(f4GL&%w498K~=MMtz!4D@zDkU#+?NEHX60>&Cp^PUN0w@!elY(pSX1HF)UnX%C5Z z^()Ue0qUR&2FOE&0vJheeYzFIFjmGOBzcv1NbBu3f|`sK)US3#9hp|n+j)-+0xZk* zQVgRo55ej+d@AsTm(u8~V;skct36^Ho>rLJUv885{;!1?h9(1*>ZZ~jW9c1pv{KToTA>dvX=D`K!q&zTy!t%$CdO%eMx~*_ z)PvG@1s9*}&3g2)F+Xtym!Nox5}t%Ijh4~*p39*^l+(V(g4*wjXqxA3cC)DTm^rR` zmn)D|nx4}{1RGVCA1fST&lA~Mg9>FZ+8`^o*Bjrar6}msfxr?8F}}tZU&J)nXk}DI=hlzdDUNuNd!3OEs;zMh0kOd7v`7AQJIfn!%#jGprMNI`ti7zIs;2?!m=1Y(TJLz&i@-$SkU&(?Lm z0;pu`m(wU_RGV;FQsl+n(6;e`J1_7R+adfzaM);Y{7E=(#%Kq zitypltKok`GWgc0Ymwr5DXmGl9`OTVO%PB*oY}TxIIp}^TzQ_&eHF1x~{#%PgUKn@|M-g45#`$g13 zc>^gO1TSMlig94ope#g<#4~xxgjMXwY(O2=*fC1HN((KODWam%uB(;p0d-7)uGv-a zq|+4#!Wu<7#vLL;)eNOBk%h>^$V9xqBmu^DxZQGLI*V_AiS!_5kr+z%%Pgl4PQNjXvBID zoCo2X!Ln!2(292w>4Lbhh-^<<@&i)bGAmF`MP-pA9&CzjfbTvyc(97R&&hE=0^*Sx zaVz|xDSaI(H55fM=(3PXyUM}ENR!-Fn7DiJFq3ptLtz1jXqOLt=vu zsw1~+w3Z6zjgCQy;J;dRpfyhOZX?b!${};`qgs?YwY>2oa1VL>b!;cB>YMWS%wGnV2I` zF3*$Lac5mNd85JDb|C1(UA6cjV3f!An5};qmqqBmEMKD)yb~XaijFrcgU;{rfGcNp zl0)agvY&u^C=aGAtjR~TpNETTh2eg6jGnHJdTJ6bJssc!$`C37On>qy=uGc$d|aUt z+^xr-BL%4>C3mN_F782jbvLOz)$KGG*ocN>DBy*G@NAr2M?^d-V~ANyxK2>p8Mf$&v`UQ|VmeyM$k+Eo<}%zmNojrRhg5*_P#K<+w!9zQcF6CV8l zo4<;*9zSJ|C+YEU9)&v53@f;KLh>r2v#e*+&2DqYqCbko8fWyb3&v8V`dZ*8f%+@$m({^Yh#!j~sr^jy zzF^s@`zyg4H{A{o%_G~_aa$eRL}te;>4Rd>j_qR3g!8eK;fy3r&s_w&TC`J84gO4B z5-DY3FSB=NxSe5;yFji|&q#KA`1Km@|9?qGBOUJA?ly`VO`*w_OgP?6phJIRpR0MU z=2;ByW}ahJjo&_@VhoaNqAnWX3H{TbeiTS0F)N^h=t_bX5xxxL25L~XiPiIk^8gIfgn>jYEgf9w3Qz;L%kw# z0XRwg#CD(8dBO8WCt(z()|NU_4uC-v0fI*6N;xTclG_*Esj?z0Hk@C)3sXKSHZB;|{z9Ow zQXh1SD>CO~)+X>cW|(XvK<%;LB=A&qj8kIO7~xr7W|(N<^xt6>(IQ31qGwT11;6^! z^DtwsSJ82thghsJA5S#q&#c&!j4LDmeI56koR$;+<-JDB2c6R=Uj(I6%OusJ+M!4> zz{Y%&5x1tsq1|%PuO`PQB61!gi;?r}31(A3JebV)#vDW!>3IG!a{VlQcCja8LuSxL zCm_}*hLkNFUWsBpX-C+^n7YlCiYr%4O{Re%0q^?^O47~YQ{3edVT}DSy{Z9B{pq=y z=V%Cn6_INbYN&#& z!c8y%wH?pOU#H(_I*L?mK0=fOe8^2T>wq=&UU|}9t<$OV_`MaH-r?cQbj>CsNKh70 zN;7rpPr#&kj(R3NBN_FH{?$mWyMsOVg*hdlB@q0Jh2RQ?uz)obYm$h?%-Olvv2 z+?<=fqBOjJ7U#d@*n4<|Oyd!jfxid|j4-(#4TL%>PGew1P85G)6M&vzy^IHb2n+7a zC35sD+(MSky_kI3wG5dA|cVkhjjn`T(H zZ(gLwU;za7=j3usWF&94@88HufM2zwD;L2PRP?eSKJjddrGNlUnM8UFmVi`ac;q8E6FMO zz@nE2YrXuqn_vyS6(&Ev!Xqt@>*2&BJ|`38)PjNma|74aLS1yqN5@Kw{?reMsF`OY zBIfTro|Sd3`p>t9vTtsSg#nOn(N3z84JQ@*QnuVtYA)~mXB=U^|0X`C8W)s((|D^j zTN|mzc3gj4uN~L;o$Ixpu;Zc}W;YyP3S-tPtuU*56N8<}p+YZ;Ou+K#6u5zp8u`h7 zSTx|p|N0gsG>$VI&9xmU1mH6hs+HUyi`#lMk)b6U#GCCk{%Wi z5lq1(%K{C2)XH<3S6KmfC-vBt5MHPxAHEjeg6nM2Tij~x%f$7_mj^RmW@4_y9mQnP zJKdPEUM+emT85$Ubv>FY&lY$7AN@XOqWu7k6$2m$-yjHuy3y}DFQ)Tb@$HE3gdHf= zV0A>b*mZySNnTEv_H-i(^aal=(8WFPh94l!ii9mZsbxvQOo08|5iBRz^u{kWx{bGQPHaB#PAe2^5-Rkm?N@Nj$7QESdkB0VPYPJY1?JIEU- ziTo}*eb}Tcl1J zx8Rp&))9^vZ*9Lfe1e^v-1uU{ZU>UPXJoB+KGO$S>5;`=e$%!UVoYtZ$0E9A(Ou!k z2LQeDOM>V=tbZD0O^Nr=g$B#!KO^A)F@<_i;!1HfiAOm^L=uan={nLNN@Dmg8>J7` zxEr6K9b*DGNyWA`wH|(zPJ)PEX|ke3dJI;)MQ4SBTkzsg3wXfv@r(KttDoGIbinuL z04^0{y0GvNRE!T~iQz~k;s)%`Fb&6@JGBXUE70PPwD27fT2%+O(MxK>g>E zAc}~39X8OBsZw%s>^j|vre9-1@2wCWr40RVQ--cz2gO$aqOj&bJbVIz*?xk{c8uFh zFnbVfy|R=9GlD7iBACra8k+WkhN#*4ccb4SNOn-5LFY#_sB@fhWI>{I4@kw$!LqEM zyN)pTc9g&ixVHUH(TE$+$QuoPCY5OxYQO|ngNB2FY*2cn{g(37?IpYh+%_5HK+(NI zwbrYYavK|GHl$UYQX28o3ghHR+-MkrRSixRk=3ergd0%e_t&5gg7zV#Dq5boIyxjNjFKD;{~GG4;vt3hlsf9r<@J zvuI}gwRrbB7rhKune{1b{x}`TYO(O8>S&&c+*~CN zt>kpdusm&?HRd=9!Q(fZ(!y2E1%Ia1&2Af(CN{Y2{Q?ff^mAz(1y=*1>K1Qx>kNCt zTA<4^JI!^Ag=Vf_bZot;EMIT549!@e34A5tCk7ss0o(0Y|d}_+K);B4La(+frVGePW zbB8Cg`LEPkw6RLEXSu+27k9W`pzz`mL~ubw2TP&#%)Ksc5LU z*+K>>$dB?Y^=V>T>HPW4gkzn8oeeK1 z^^o5>rHjmtmyE&zas_V&B(Rss*EZ$n(Xn}TN)nA`3g01S^SoxgulA5=3qxxSO%_i1 zW*2cwjofVHtVV_`%jvaQmX9@7Ou_vWj^LMSUQN1V8=3qBJvJD+Pp{W=H~BO9(*Xfx zi+gU+bK2zr6lR4>PwRPr=XAc=I=@8EYUYz8&D^ApqaP+~vpqIjGZpUHnyGfr)=Z0g zZdR~pm8sP`-KgW2c;JfG`~jL!aOmS`6UM3xI%@GlAymC3VOHb%}F5A@hkS))b+ZWJJ>gOqBYkYHTS-<=1!!!6Ro)+ zftf$G)ZBnIcOuQ57&W(3HTdSl;M9p>rAgUEPuem*CUj#I6S_}d)y0bqtph4CiIQUF z)k2auW+vYV6peLJN5v$?`sb!wKYzls7tA|N!Jg;i3_)^Qo?Dz?nkxW<^lR??C+2(w z8Ea8N;!=0>#R6d{hS(&PU@xO{DguCl*&wwso9mULqrQ0ZT5XS{GovHg^=K7R&Upeq zNWD|6RSwwBd_dEma@Q*NB$`rYWvU_*X9IwbO;;*WCm{&yH1*gi_f?j)Gcno0y-^L+ zs{yrVx)$o^z4$-B(pm>#>;pZF>EgeVNae@}DOwOH%#;X}`Yfj=TL?o)`kDwtR>iq? zpj0u3=Ihf?^oi#>Up!czB{jbv0He1E3jYBF`LP5}Uv6I+44g5;)g=cg*}-?WjsmSXmYi6m=^^mF{^m zF6+c0?q<*Y^n^yOW9Qoh2GFj)?Ng1tsTivy*{_2}aevk(h8 zI(svw_}G7G$zI4P-=`-w!N2z@b;b4eL~bzParze1D@Ld z4Ll$B?Y*rKyavw%ONrm0gkX7<{~p(C_!_oT2M=Q-o+FfMoWzrCoGu<2r*5B?aj~bv zr))SnsRzoSj99hGMBitZe|P=uQeYy(|J{4{ciw;fFYy0aYBc=g)ad&AQA>&6pak4F z{P(zC!!f*-yGAWuBW$Bq-L`z_E0wY zMEhX4nCyOjJG%G|39bXnqj5O7)Pea-Xyoqy4L=Mz5A<-pt&qdk51sN5UsOV{{1u2) z{fz51l+%nGkA3w+Q+QNAZX>(z$G-B5nY}y#zJO zzyj24I`MIUOgA}s-Z*~m$MK% z%J_@vy2``*_6KOg`tuSha?yhlh_z~O(1TvX`+3{DKO&V;{rL}Nqd#JQ>Q6PlO}Wqw znVY#>BGH#hy4#q7&ReVo>)?edYaRUl-W|O4mw$B!Kju5|HmY9N!5T}6-=KtGd8Pjz z*K7DH_MNg0y7AJK9@W1s%0>TbegEqC#ptXBl2E&1MmJj#>(IX_vvug0h#8HH*sC}H z)g3yW`iuenF9CoD84b`lkdVW zln;C0@}1J0TL(@@LNabj2WC6r?0DaS=MjIMEv4rP6UhSIvox6AOC$?AS5TjI;2>JC z4lK5m_zg-3me2R!<9ZGMR;`cffGBZP2fj!ayF6(;}<92=VU3=z}XzN^71 zYOoYdmte@8#vo;2Bqg~i=oFhMwKO=kw^A{<)97k7uE}^}(F@`Iuk8tpsAd!}|D`OB zi~rmnC0$)wM#>&>hyA-7`M&~jXHlOaPSJu5aVJ;20;$Rn-lHrxk;Mg;rb0P^wvnJ5OQIZ2t`bgj z{;?ZX4%$0%qSV_IT=9(Zu<@`>-Zx~QXggO5&Khu`y^V;=!fE#eUB_Bp4x`ww6TMI| znchf>Ew3g^+dbQ5;k3P@k<*dMScvLhRcQAp{%C=;=VL^w?oD--#nE;fszuMMz^bUg z#mo%rZHjrSFRP<3$JrNY>pMTjV+Yr@cZ$Jx3|9r6%l0Ijuc&Y3WFt9)9%z%L(>|S7 za;m-fPydQhs*9%*$=U1_&5xp|zuhZ~=Jlv7Uo6ie!gX+ZHz2DFXZ?LFJxqJF!$q^-kKeXQ9Puj_Oqw7g@QyY2u6<;SD=%GUWZ-ZP)b) zy@KR!`(103vC*H@x-qen)NIv_cH{!T+>JDBxrdayF!43L6Uc0g5P?o0rLf|CnOsQx zou=GyBgcIR4Vv39c)lpGMRBgt08vH?5DAdnVZ2ickkvd(7l0~w4#dyadv0;)r`rAT zqzy6?LSID|%i~GG*^7os6^2h%1gc`DbDUpVrl(>|y3Yv-;EX zJpZiDcPkD2HH)S}P7N)gC$G|TQQ!Q1+1JF4~l(;#Rm&%{RtD=T=aSp2zDEQpw6 zA1$_qpfMK1oq>*(9PLFc^*v3o0cp8YubYm0@K)s?d{&jKLQVJO{dz!s(I7L=PF^@a z{wP1#cfYQ?J>xIQOP}Fa!&%z76 z5j>qpxx~TqA#!J8_gasVVoong2R%a6&SWqu#942mq z^;XiSIjK#ur&P)|D8vzYzEQC&yDrwWDIgQlt}ZlsOFq^b0#4;Y?+v=%kgMmtU7d{5 zSSxWr|2(M!cXLTWEa96}zuZJd7zux^L1EVU1w{LUsmShHbehM2(+I1``bx0aW0oNn zVkv97t@(UZrUg+ZfgDV^(U2M(?C3!6YFZg(7%QIk6HO?T!n_C#+LSe#)mJ0vRL$5y z^p)}1NtNm+U7MB$h06>jMAl?KM7(9XH=yE_RhNUS z@k*@S*7(sr{Kr18=!I_JQ%gOS(wrziOV~{`Nn#Qe5OOBBKGX3eccyvuuwFN#FLfGX z9WzW9PKE1W)F-#nMI)LPwR&gN1w^pyle|Hji@&Z*Gt#m4@5o0q=uEQz6B<;Q00$Vy zwn0!aSqZUt*PIuevz`MRLs=hLrQL$(cT=OT$ME4*%*%5N2*CDo4$dqSC@yP}!&SHd z;-Ts#cqmW~x*fN@twFif$a#baNvf6ef&+OuB%YLsTOBVod7t9-Ta!1bNp){9AC-?< zOvm2Ha>%7P*r{P$K_2LOh{cw1z_-ScH)bnNSBSzn7baGxy4oKL$HA%A(PTyVlz1Ei zCgYT-#C(=$)LB@rbA~JiRs}UnhRB!VCd}MRgxSSm<53+b6lYUc#h^7~8iF76W_q5g zY6!00^igh`exPCL?QT1g+d;t4bjNc93B_N5BE$iCpDaS%s-LeNTd5mEy=u$7$Q^+Y z8~j{fIpdTm{C%|ngCr>1>%hWB?URR(zg5z1dywCYNgSn&hob_UZ$57uUSdELZ*}gqJ!%=D*!N2?r zD9oJ35k2m?uG!zX%5A_sACWn6PQ)0L`-Nwc%a*6GPWcNnK}yt{`0FxtMjgt=9#1D<<~Ey;kr6yg zd_&+pf<>0~>?c3Q{tO$_O2%uef7QaprF=3Gq>C?JXOVx}67!_?P9wjrwUzCn)=`VE zi}GD2+o)T0B3p~tbQ85`om7hc^mRzBO6GeDX}oy3&!JTPh0ltbLw`pc-ND`(6&6oh%CE2!bPdV&Q|<$Q>W}DYE8oQP zlusffI9A!9vsKyiW8Szf1`&OC%mjYZ)F-G=g+)La#TCX~PiY&U7Ct-h*YP9-0C8GF z$zL#qb%zAml+9w73rJI$B_yf-T9u*fB$qdf(=IL4C>6v`widV-+*l5+Qn z969%*c;Cx8hjTA`~5v@PnznvpZC6n%KYUS1l|HvsE!C4-@kTJ&I+zIo6T)$|CobB_?hv)>s|Ackk)YY#9WfO5%2hrMsE zGj+xMV2Ma`93}KU1iA7M4uqn(K<10IRM~ne<<7m4nZp_=WpD7dY_tuYvWQeckKOzx z@^nkzcq95!jk1#9rgf3|3a@d)rq^^DvlYE)H)H?@T^67w!%s?7^{gq?Q>9WASYoA1 z*4@`xGi39pJwq$OmPa;l$9A!ZKHmFa)9SL zD1st7rAv4(HKJ=r8+e@6j5=+RqojS!aQ2nf{MgHdhuHahr% z^_%-6(fy{Vm1+Pe?D(lH&oNW)kMXo{;wMf}OK9j{ai;l~g*y0Ikj!`pT;FTB79b?r znEN-&iClX^Xp+$&gx@1{A)A{7I;B`keo5PX77AS$%wA+ok9K8%7iDs1^hC%$#m?4< zsG~zFRWh9`=|E|+SeVpO57Mo~a}idOrW z-W%(#D4s_i zW7Kf*7rY3-Vq80NsfAZy)w#cQ6)j6HDkiyga`|{{ybuSDb-ubtCk3xKt1;N*=g0f0 zEz8b9KQ21Ce!DSRzwz_64XMJdFEBZ8Y&}Diph2AY#kDcqjSuC#On;_z3sIxJjlm#oaPa{){#@N%$iJy$x zxO*Jiz+Yy-jA8G&$~?#m6R&~;eV65t$D<+?cwVn#?haN{bh>K z@({R0&H^{fxdVs^zdWf`V(o%z&-~4a`DGnYF`Y@?43M)@f^|if^eRIM=HuNVbD70nfCd!f( zRVj;`c}L&?{WFKWD*&!#>&;;1+KE;4fbc@1U!Ajsa@jZ^DAXFe*#oA?#ovHEwd#vn zDIP7DU>A7H(^NU^-S%0Y2qE9S6N;sTRGuHa5?*$~uVsh-f{mHhap5iFnLy6-?h`P$ zC_7J7daESw)9lX1KpyXhR}g!;EA8FaL%~_h`5yK$hUPF7jWN=^_g@-T>}d@D4kI*i zBU8bgoh@`lT&hxJNVSWT)t80y9~zNosXleQEh{IIC??yA7~vG1oVNEyc5z57B;1ft zy61(6Fah2}Sy_2i^cg!ZVf|juP3I=dgv*l6KG0Q>ROD4SUFL6?PX{XqJ9;oIk_aSWtJtec<+T0xIyRVu{^ zATF>TzAgOh0}f1eX+o7xqW`MpYn9`zPHL$J#DD?tuqe*YSt&fF|Du^*tDl^sSh-T` zCQWIuehe-)0?LL$^X0M9iZGNN(fjR(nK%}&qb9d*M@_0B|K8fCz(9i3Z+_5Q`#K}5 zxpp^Od%F|#rm+gJIj3tvp@myGG3|wMlWyT0Ao@9CCNu!FYblAw@R*RE4 zpICP&s4jR|UMIXw+g{;fjvqr*a2oszW&FyhM2+G$AbE0^F!pK11wE}TiSy593fDsB zm-qW-h@|0-mWyzRk(4#YM6a26(?jhqai+|pw^X;k4@#Y|7=nr&&c)vJQ-$_>i?yuu zj`DX4!Bn)e0gIJUYC*I#4{Em~&EUeC<#pX9)B!?GCcKI`-5OGgR_@M)b0+C#-Do{z zAN3NS0ty@#_!V+7TrMpbFwN+{iw@>eZ@2HJ{2V`AHgVi+dhT_78Hr`H2Vu0tFpaG^ zM=Ra}ac7&zsCW{9vT}`OM{EY@2OEla(*eE7Xp+0+a6@=)?6OFLmPksHl*!@_hS+8a z8bi+GaeJ<_tvzsZKV!T-6XpJbn=cQOd(svhb5cP-z4OmkuQ8RMX8;h+5%L{B@%$nU zM>?Jkdc%6;^P!v@1c~S8Z4l0GpOhxWPbT(GLuz~bZ;CpxmscXZTfKwyidzo(;QsuP zlXz9tJE#;X92Kb-I_gIVGH>AY);+_&6fR~J{}qAf=g)0m1LIVrZGvr3iOK(SwbX$Y zWhAIC7`SC(`&k=L_Ah;H`kM6B>3LUQMaH{q>$p^(*F6HtBw7!OJxKCA`zq3;Pq^ue!7h;a3V)ks z^lW<#5<+cN%2`)tbPVlG5dl@4#>X74TAqP)Ahni$GTU*p8H2te@~n=u4+Oh#&vfeC zn-#KSTCsv)6uJIlZ)IY54-zdPDe*at%_HIozR|stF5^b?MlRALW0d+yd{}fkoxkJb zRErzuj`N{@_1e2_5~^Cg`)*vH-?EbTeSQ?S?&4BX&* zHP7i|CrVM@kLqJndK;PGmu(rjp#i4S#}io&D4o%x%ZK#Q>tIh_wqWb+c0O7z=; z+YVmjVz)jX(g!NJd62({!P)60d?^7<52MGC3b74-*u?oYy)!WV1_Hx$}~+ zOpa)gav~#~>2EWCcw}0(($Fr@#tD+mQ0Sy9c?kLam-uu1(@?t|!Wk6R8}4qO3+^1f z41*4@dmo>|oTHa)!q6r&+z|O|E`+?cZwptBY@P?9xezCLnsbq$9%Zr!m-WJ$m3y-+ zH7l|Pc?fodH;fmFs0?Vd!IwDymcFq4jLOs6)qeM}V# zDP_Gv4ESgkQjE#BgMa}LQbK|e(kX~oAqU9x#n}ihU;>UT*fRd zIbv{K_PS=9Am)GzP+GZDU8l#NSGOf;TK=-z^Tj{)BgHaabK_mCM)Wv+1UwjPe16Fo zq{SHIM#msOgbGA|;)@^L3JD+-V1jM>*b2?_MGtC@As@sEV|kzw)Boi%;WJSt5i!$P z;B`t5i12k9k&M#jo!+EMJ%>fS7DP@nF7(oZOkaENNwIOU>_(D2n#ds8sXU~T7Kv}E z%Muqa@kdWv4lwFl`GXxyd>}fCXO#L2sj#H9nZ97oZM53LnLA}MgUVi;q?Ppam!(FY zwq|TMT+1FR9i#z~(*mS9Qma`q>Y@=gP5GS9@Nn^$5YZ@J|0}`MeS$Nwdb@l0>}lwN zufGkB8^Vh)UPmT*w|#|QxmLE*6mqQ_8iHMo!Asd-zYx6(b6?+&=>wXnd2+_?%fj52 zk;c}IHVtsHXzv7b^NvcROz*x4upCL5{a$pGG4Xpe+~dUSpY_g}@&Sh8oU$5fd_+|b zYGfW}C|gWci4iw&s~P(RQI+=2K7+T;t@uD=>~;OB;^W*YHI1=?pL(bLmkq%{8o7n} zJt7l4_O>4zY#@-h>kcy^$!ax*VlNsg&Na)%V4(?Xj9 zNi97;tFGaOaTTQXTYKvXky1oPaAe7BfkDekRMjD(qqb4Hsvr4ly81kH^){7@ zuFPU^bd{x%&JoYMjlUNK~?rN1Ke_Glpf$&*c5s=EM64_)QKKu##!lQ zAz{2NB%FygolZU7{@>FCw1M-kuWU zqvAA79t}Aog=Hqa*Mbn3q&=9;7!@GpSAD)YU}bDK$kJ;M>M| zg6CYBo9I2v#BV@dhkP&bK5k1c)C^PUs~7@>TTb)3)<;kOme$`EZM=He_f|}P&+SbA zeXnIdoZE6#Z~Yl^sdZU((>Hs!$8;$pi#I@FVs1y5c|zE- zxZoMx9Ofx_Ua(bdy{IOh=cD;$+F9_b8rw_n{#L*6m`s|^-zQkUc;PmABNFEw;`@f2 z_l<-47@~jsyv_wt52ilDL(2YfY#E)Piyz_#S%Yi(fcJy@kUX-%y&twCm%Z+9^2u9w zxE7`Z9?6yIfEwWbLfuDjZk6M3KzRHVIQZyybsK2+=-E+&)b}QRYIu!{^JgoW;QiQ=!VU*=z+Du*OHihhl%c5e;e?)($<{v+)*K-KF=!jZ2a z>*wY=-4yv2abRN))0VNH(ahr-t@7`x2!t?DY&&J#2X48keF;^3X-vHq)1rF)(Rx1( zVV#`6S&bjoLwfeCJ|1&*@3gv28kL_OJ%4G;bDclo>>1bJXGF&iz`-As0DMAyIN2EG zZRQ-jlW9FoAp@;vrv}=VD|>eEhG>Og=dEPRUX$s5s3CvFQ9@3&%H84TKgYGD$Lwtg z(nr~sKlA%BTv69>xMf?iS_^Yw#m5;IVbJ~N43RglJnbrnkI4U<~S|>mk7mZ}Y zGFZ)KY?Cg*hKOcmr_Ap~twgdM(mX#KJZb=UzM5%lt(KDs56UD?&ykz3TDiB@QW)>` zklZNixlZTF`tx%3$S#}9-iiRre8-xZL>f-Y;4RMl z%YPj|ZJk_waWXq&Clh0Bo8_u7+uTX!Y=6VyRg;XC7ncKvckOvXxD7j65 z#W|tCNURr+(UX^i%T9}DTQ@h5dtDp!a$)YVctdT05T6N|u&sQgA=rQqFc*6}O%Ttv z;%CFMk7SrBss)(S@k2xEja$F$b>-o9!lMs{_;|kFvDw$FxrYWNV<(Xo5Ez*Td zNGCs`Z%#~W#~2-Go2m|S9y|GJanDt}1C7g@o!iWam=eDj=UiW$6OBkp)gIENiu1vU z{I+vgQAynzlRYYrX%(>H6fFhOv<;3F{^7flW%J3^LQLJdWCwU4ZX>WChLp7sfWL7> zZ{5K|h(JsFnK83-o?`%EokFE!$XX50F{V(eaAT1%SezPl-vH zk-voa_7xGtRH|r&n!f=1;7DQbQh^Oo{UlceKz9{wP&0vC-6WLfwmL*= z+-Q{5ArD}f>uZmAb1xFM*ZYSauVF(vI87usMN|Y()fUzpCxbr#R1|MU&ShHrSjtEp z^j2@DVv@fHN8qS96Qa!8T7{R)+e}pGBjm2?;;1W%A8*937d4IOXNxfYYdI7y3(MrC zK+;$4hMbO%fU~27V)(&xIODdxrqBbXq?s_cePjm9C61nG0kbYqagN2r5Z1{8q9&&D zgwDs6Rl$0a<_T}N?*Kb-KX?icF!{{VsYkqStz{Hf^8r*FV1803ZJkK;30mLg3A ziJPP^6pi63+pr9!p0KD!-bUFlVNCVi`fOB!w>K<*R?V@F7&U+~JpE}x_{PXDfo_X} z2J%nW=(k;hAhnmiHX9rnbzyR>)c0S#L&`IllgzY!S`w~Afh@-BK{puOnI|7CE@(oK zv1}7n{4FJz%Q29MQqcz7tY;Y}$LfHNN>ZrEk)8R^7$=EfTp1Q8dq6Tovy{c}DZH0o zQ3lhHY*e=&Olm;#E8+nQaIEEKD8S7@Zl+1HK~sa=VaYPd7ypk-^#Vo}SD8LD{FGG$Mjf}bH{$`K(6t7wdNSdIF6;_<-p_BHl`x?DytiKOQBF-5 zUNa$anD!8I)SGHVom`}1v!W+8dQxFOSnrPNP-g^#bcUW+N6$N==fZ~YOsL2*_7GEN z9i2<)Zs)74IF7JLU87%!xA;}*tFI;{RX^|Y)x%egcwM5K+7#VHQ?6MH~q?9rj~cvc53Hlx_`&ObiqY`8WS_(8GOlOea%p=u zODMEYbAp!Bn&Wg>6|T4DD1E-n5uoHkR}}Q zHiF~|(_UgtC$(?1@6o6$w9O!46;rT!;cIAwQ<2!MwDp<%%%lJ*&~n5@2(}9H*CW9M z+)86>1n@(W(YZH9(y0U9$_`UPJBhSJK$qc+h(!1fGy?}toE5N^RMY=QT4p$2iKTX| zz*7#@)^n%6>rJogLH2}3br(Nw%F5}-h>jpaQT-Z005h@cYPHgvhZFTW2+~_`;v+Gs2A)M z38&Z+uF|K}QNW3Cr{jr%vcg0v(8vHUfRcAcDVmWq!3%}2S7rPba1wsVREJ{0VPe!q z8r(>T>Etd7Rg)T!A}i&;VK418)+C2t18Rx|_JbCO@dPC)Ht!scW8mP}R|t{D$8UB3EQ-K*6M^w@?}rx< z1Lk!rUautL#8TPL1N`krcnq~aj_{B@EhfseGNYWCv>_L2#4oPhZ;`hMXJ2B!k4Bh`mBiwP7SXfA9$YwDzH;pqWEPBl&te=YW9T7EV zR3>Nj44F;;mrU7Gxq35#P!B3byV)BkRCeVZ%#7Xy2VG9#2W(W>VBsa!>L2x z0yp8}KFwj4awtzOC@RcC#C(J>w#__FcWz=k#O8Qm;W*8~?=}F_saM;#`{JLHOwuUS zj}bQv?9%+W{JCL8)%k8SksmIMrM3mED7rel%MSssD9TU0HSbBb;tfE-v7U_^4`V_S#X_%&b%=iR76c38pjeja=y##yNw*Z z)g;zr0&-6AJX6iUFRa#O!oS0%MDpF>DY1uwyyhjFB{q==O@(SZi_>ai$~b3 z%Z81-HLNKO;zdH1b>8zCONkQfDGia#nJ+%Wh*6g$KQU|0{FHj=R-*IbSNU-G%!MtS z6}W^-na>a96nLYJn8=kTk#)1C!I{FUmu2DbGo8o(c0kfpWXzNv_<$fo8g3z0&`I#u zzA^@uZF`jdQxyV{^o~Z#7XjwjGsPY2=rUTA_f zhwy2J1|Bl4mdTTv4Q(uNbOxQD2gT0h%C`18D;vXeQVz-05Nu4>5??mZ5bW^-r0|@L z>CU~!)8Q9RY&(G0>I0qc#M0j9dfkyq`0Nm;>i#L#x)9Qojg{gy8;J2({rBqoNm+e; z{|GhRoI#g8iB|(d7{`ScbDf`m9DV?WZq?*s2P3BizOL)~Q#%#M#45cvnZN5~`4Q^5 zr|py3ujN}1;UuGp*Vp{q0aFF=Nd=FFA4XM0Reo7Qc)lZ7yg>s z|98>}_nO?2v4@v&8p_rYBU3faM<8QJ7!d?}u7zl3@;Z|kb6_?~tG+}-5}m}PltbD_ zIJ>#(s`Rz&$zg|x3dc5FDP3*$RPajS$J=eD=<}!(cUM^0IWBbK2%^f7Aq(-a4Xa5|dVbn%lT5>Pk=-SlOE z_M!SyC>~Fy{H^{81O>Yb^B1mJWXmP-OdlXQ9QE+tB|+N>tTlyMEO5cJ`f*X8|G-h6 z66t%fJXQ@dP1MaSMi}-*143vm2nL)}>xh6s@Cn!@#R4sa0B#<9hoXk7mE7N)| z*}ZQgS2v8p8D$$!S&pbTf7q_{HQC@zi|We+k6wjK>;YQJw7$~pL-XJliuxrLyP3Q6rZT&`ErUbM!0#| zjS{I%=Cn))k7AAPPXDP$X@XeT(l3EmBfq~c%t{l8nIqdR0vg!an?jWsvM3RhmfaCD zhqK_Z^R3gpE)NJh-->(P&$_lJzeHv+WY{%v3OnY@w(bzXxt${l9UleyD>Ma6>CR)s zc?9~wx$s`sWrCoUGZAOv?wj_m&bLl${|O^5H^z$iE#uq%m!x7MpCCf>pG|2ncNSw9 zbtJ?oioCO7UzIBGzJ)H|)Iqw7s#pvb@>gL^srD7$IB=K-<)>&t0#Ukcdn4k@Ulc58V0J2JC z!DHC#HE*R7wQvNWba-9F+%+ukP`ZPECU0q5c20$f;d#*;axBA>YB5>8SPoj7`kU+7zY;Fn zgqmc(77b@*RUrj3$h#ph=LGi{e_C(|OV|v?mkal?ky+9^8#~aLI@bQ8gN4_tm^al? zoBo+f(7{>E3-hyrf!YxyQ4?F3)m&Isk6x|k%Dc?nq1_sOmIO&U-~7irb%h;t8dQQ&?4CUGzoWn?iKiz2|8O{{u1 z+pAJ8CqE3=-4kr_E@v;r1aH*=a=Q@uMc@Qm&nDgih%!ijdJ;XE)9lgO@ z(UZosPpA6ZZWPMJq!K%7hCncI;|xhG_*h?ACq1M4ljiiYaFsfED-k_W(Y1eFU_1pT zGZugK<^-(El`m40kFnqsQf*JF&-Zd0g12ioaMsDqUrY5ZyWub4@yVppI?#JSxS9H` zFAFC%C0onS~&R;`?|1SU-V@WyoNNIC1XDu41!+g z1n?0>a2d*12?y>rPDLEe=N9v%uH<^U%X`gUZI|sc=NZ@$wcYKqYeh1&Ny2mqPwZl` zF7S*FjF@Gg$E0Hb$ugT{K)zRO$1uOatqoqM*7 zFQ12MmRUx911#O0tx`ok`@@1a7&=+*`sa+OE^`g&aSiFDOZQ~y>mCM$?5M72@y|H} z^}9+91%(p*8pbO_UTQ!{>r1VUUk{CrY-3$NCGN7z;CZbaj+#lCB zL7xox9KM;A+@W7637=(vl|SH}Z0lo4k-dz{)JGT&VQhq=k}|V|IrfD!WRtE>Rt>)^ znzv&PzzLs`y^u3|0jsVhw|ylSmOZM_mf$#VY$VlA1kknv2thWvyi~?^sN4hxohQ3RktLI4 zOjIE6<`X=pNpAC_1PDY-zq5T$@HTNP>DbQH+if4G$Kn9>5)0)KU8|>HKyg0_{}Da~ zyFxZC=Hw#699UxNGB+Wm>-DDWU>o6v;BoMJH+aQyrLkr%IA4!vMf|8ziEQf$$WMBC z45Mq}kn!_1-9#H4h&$@2aXS&2E8+bmA2mnBFkVaq{nIfrG|>o?eNYM3Lu2sg$fl^5 zz3JDE2>)2E%Gq@Yg31U`TAxL_W%eF2j8GrOXStach2Ov89;1cZH0Pul^&bLlrBo%+ zGcw}5`(9T<;ux`?oD^=pzAPTGXd<6Wz1V&m<~wYlmNH^=6Bl8#&AcRM{QS(d4XM|b zf6~X(70&rbPzC;S$@q~0KUQE2x^eyhsFQD*ux%F7tgo=FMH|g2Hu?l#zhJ6ws6B=R z%6&mTW-NYs$z=Hs0>0R?&JRU;MN~s&Rcz&Zs_=L*>MQT#ERep@7$V|%gVPXq5 zsu7!<&+#w%<)XJ@BOp{vq;4)uhn4To<4%aM;HOS_D@VjGz>8%gbhZ-zg0(0YRyCVi zg+qC3bliEcl`V5GWoi#*VuOw0G@wP0aGi~93Pu>lbnULo!D+iFwxyny_j$vT6f>$&mjWBGuZrs$L6O%j4;!soz7}O9V1; zS}q-!4T=vgx`Z!k$DgkW@*-4=3Rd&T(c(OYXFqK%hR`4OQ^c7vJto)w1GHk*7Xn@%+f{*@&gVdn>ZIi*>7e2+c_x>p1F$C7 zwqR7q^y^H!4AN|PH8sOBEL*Nic7UEzS7e>4F?ASiR{RauC+&6Nq+4ge0D)VzF!n=w zv_vbC(Y%KnJ^cC4@d&qxEJS`1&7`ex*FgJJAQ8%FeSMslzmh7&&koJ^8y*B>W)#~F zRijWwP+Mn|{D(+@aG9`GEIhC+n#N@1hki5L*FfVUQ@AKg!YzyX(l7~EM$V(-q~UpM zi}UN^h;fK3{@#2i9j+1>LGu7+L{R*EtZ?~U%0b{L`?U@zHcBYxru4>6Z{=RD=`l_| zFwnLQ;kpaML3WTbhOx z71dEEbC{afnPty0!cB57Rf)7rm9eitr_eAf-ag|A)l>GIbnH?_r58}NDajvXj1n$( z6a9mygiVt_Wj;Fnk(;Wi9{0oazMIeCwp)Xv9@{21eWUmH8(_Y!Un9n8?^XJ!(FYey z2D)aT(dY-q#~lEo`CQJ&h*;fcGJn)O{N6Ppd{(nekihuHsT&Gs?-NEf$8*bCskpc5 zK^hpNNn|qq3%C66MqIQw4tNzXNzC!1qyb*Ly6<+^?8CQ}-Pz8chSMt!Z zbh#cdSNvH0N#x_eC~fMqoG35*QxpHHR}<~nQI`hNx)R=aBK;umP~T=8EOQ&KW}Y3q zp(Oz+o0I(c+5ED9KI%h6;XK8|yyT}|_PX|K={y(`f008iO6iNosrrsWC;1KFXgyI{z_O&7SN@$qOU!RyMh>I6*M- z@6!429K~Mkeu}->fA!`HR;deguZg(R)k;+-U8a3W32!3@cIo{1!!E=qw#7C=e=8dAQiqji%LCW=m&gx;?jY>F^jcJnx}C9j+3(n zVDut)>YcrxmUr>*wKu)%S9}WVv*-nB9h8~yBt43R$IA|%W}hqxJFgz$rCNGw#wxcY zC;i$*{e;2|;%(K6_pYZVc0(n!Z@NYC*Q`c(E!sKT+>fgmNj>S(k!<`(Tji7z(OiYlq&&By!d&WKC~s+wvDF$9AFV&wHJpRl|_Ds4QZ=OzX1* z$P6;DO@8<-&G@CU;a|0`>9NUZ7EomW;)Y!&SyCh9lOCmf)8%riV{VF14SCS@5HErc zMHrDGGpyJpclXn0N^;l;S#g(v3b@%D%^-8kabLYPDfkkCGpu+Z6IQOxf9q)emZQOU zj|Mj#RV0+SCY^fL3!k+G9xMb(nWEPyVN#QF5}z!P8_x$rjlrJbsuKQ~r)gQ;D)=cC zgqNO3VNH8oe@~O*Ps!Bf<5(4VQqX1ybd-G<;z_rWVK0HI)(A39O0juDd0q&D<`?~h zJqq>xk=-R)tS?DIaptT{hz6h@Grg)bRl)Q+A8LYC%Z7lyC&aLuTo(#Y(ZlnR zO5OY0h;B~Zn_Lebz3_XIPfo81f`#YjWZP1!W?!iqZ{?RLknN*Iiet&_k6A6i*1f;| z-{l{V7hfPDnd}s)-X2N`>I%l*g(o5*wKJxIAXCJ{an;hgjV3#|a&lYc%UDivlMj;& zh}7$Py^BfoXghNI)2W>+28(ByP0z~n-S#%KROn3y%Y{>pQJb-BHL!~&FAFR8$vwj? zj@8qd?`Nr5kuCAU@zXSu<7#y37MA}HFqxU)^ofhA<5bs7@N8ilh12z9>eVc{m* z%64+@-_8Bttzwczc<2rJ02M=?XA7(`~3mJIUh)F{`XqITwjeNvu6i=1azKVLnBz^lUgA~KyB{c=XXTtptT3|<0AifhQs)DL8O4lxMmGbLsg0YCYRdcR zBHfJ>P&cZdNY+J>5#VNln3h)3QY2MaNce$J9$t8>edSmqhN>iR3X>rsun-co|bZ!-Qg-2`Ow1({4Oy->w>aXXXWQT&a`FU2g~&ws$r6B=gWpNo?VFAgiG z`1wz`KtkKUCMslSlr*&FcRo8v8@l(eNciELj)vH-hSV`{<)C{|rUw%n*mh}mH*mK> zuA2YQMShZ>8t_*BM%Ne+cgQHvgk4%{(dWX-8W!anV%tf7gjE%5h`so^Fj>{uy4#Np zHMZ`}tVO$T8EF!hms}G1L+)}ZmxH==!ku3O?$;gEjs_?+aqBl)&RN5armL^wYAsi% zeifPtJjAcCkiYntg?+Pc`X(?Ku<DuP@R<#sBxTq4UllI$@3y^U%*R0g1gwTR zgfk+xz^p91Sq#iQ6mzR8AY;|-W#;0@gx9e;emw#yc!M%Js)&7(jlt$@z(&V)$qsIy zPRThEE&DLs^(>nYzwhMyshyqY*cCk#%>p!@^|mW4aFpEvCkhLWnr*rp&)3H9q16)? zzIu^3m3>+`Yuq+3@r;_*>qtF0{N01XLKL}N_4naPdw>$CY5^NgJ{^fo$dE#W#2moS zcb^>*PN~e1UECyq=sxZ$M2Q`*d7%WODiiu_#0_57!9V=2D?Ip)L5N3;Ui9-epl%>P zLmXw;{Y^ea0yX(W_<0FMq0w7;zZ&5-dT@6pUqR?#sV8$b^GHg;T1GOedD)4m!Co6* zpwE6*DBx6qmkXbEtux8FU{e&&^U;UXX5AH-1d)svr8=?7Uf}4Gmq&43@WHI;P}8p5 z1m@Quw-nqahoGYHBY>CZqdsWpzrfJr>`02i9%7S%W*o3Yb;Ar4&-J)Qg_R5i8iThR zI4*@Ap#GdXKzQNvMBY{q{mjHzeg|f2jlq+K+bq|5GflWF7KpPBWLr%jWR*mHGP!UA zkXkGE2$GU>qX~Fv_sg$MSt1aC zT@wc0lXS+?BxpB%{?#(ZwPy^%5$TWa9V_8^VlAyRp;E=#z!BnLAT#IT5iJ~>bcQ93 z3>mJawyX@Kh+wStCN}(7O!9-4LA-DaJ~j~|R$-Tgm6F{P3Y7uCF28zu`~Y3itJGuM z!A=qwgsSXp^-Xn!uWmEvHxQHKcJ6n94dUG9)#9dN)sa=wc_gJ(^jTu=%+H8=wND18 z&qA$5LfgH!ENTCSs8s^Wg#r#|9sO`B2IS`GSdu`P2Bh-@QaJf<^%dzQ?H1fpc>!IIqt3DUN&5|3)AcvqLXT(r4yvhQZ1%hXi*oXG$hz~gF?AQ8RcTf zEWC9x!v&hqE*P!&5OS%-$))YA8@m=YDO4+9)Ky(#+3R3mXN2abB;j4hvw+<}=^XZY zQ!c!)@M$sW93sjOW`e_-CtyRB^)W5Q64!)OgG)#hhW$G0FaBJa(HMW0?3DwPUg0o| zIdHHO%Ft?6;meOlM1ZIvF92X8`LtWJeWT>^LbcPB&R?zh`l=UYQskYO`OXCNO7jV~ zL@a5@yp})?qneNFkDbcuS1g7vl(< zwf|#y(Rfj!*o*aQS(#=ig>Jo^HW}tBbvYv+?IJmCBoN+>=9&?{kOEl|_6~Oj;`W zHdIp*Ovb5IGVr*HlCNrm*niJ3zn8#JEA_%)KLDYzZ=m(UFaN9uEbv4HV8Y3bdXPEn zs+J6+8{>+fvQBsKF255K``I}pkU=2`E!h?mC-JU@A}zpI8g;%fhenFc=F4(~F@tPu zr29Br`~ZH0l5#2$u^y7k0Cv`syQB7+)gCt&73*=Th?`^`RHHagd9Qeho?gqy>`q_P z7;I61IhLZCq3SoOV%QjixS#q{0=qLztUI`CDHz1PlKpCBp={Eo!1?LC{C<;Y=n7Np z`RRBVUt?RrWg`SQtml1&CAK3$L~$MbPMz+pRE|Ua9!Hg(pNXw_xA5P@Te;18JdelO z)?;QeGA|M%Q*d1R5BeklL=Mo_>e9;+NbELgYb&qGdVcE#GZ2^I_zp4Q5T?$sJF+ta z;F8RZ0jGqKx<=D}hDa-$`msp$+{2I3eA&W^t=vqE3upIEER_8T_pLv zh)pQqylc8mi@uOf?e|vyGEUuL#c5jii;;fhwZ_ojI+`CCp$4Bno>P*F@LNp0l(<9r zD--^9RwNV?G|8?K6{Of>?{-9$m0hODc5l^P+=8bb*N9eyx3Gt{KbPvsv2>aC z?%LRx+Lrd#ZD@#ZCyS#jP;xTfb}JW`hI6*2gKd|S-)P1|WO>b!gk_DEX3EZFm1d@g z#+i90D~+BG$I7K1YJV}<*7;EE%?+_OoX287_V&jJ`guG{S|l8&9=IGKRfdMt|sL^&`gygBoJdHRxjut?vEas-KnX zP5H%upep}qrZ!ObK`1+}?aZ)`U&|`>J6z4e1v7)=0n*!s3G(Mgogd@Offvg%vDf)E zAKKQMObs2{T3Yug#WxYnmSaPfkHRL+)IR}-*Cj?%(>1vOGqYwRtBX(y0dzV%t%W(= z*r5E^+g}90St)iJw4IY_#kbAjaE307-xwU3@x&Nu7LBkX2t<9^@bdVd#D_qf z&`A{AsU1>GjtrkGeacY48|KF$h;sFpSresXJ?+g?7|Fm*&vrf0b~?gK!cRnnP;mwi z_w?Hjzj-ct2RgLtq{bW<`H5=JICgOl| zjn{RMcYm)6q(uxnU@AdC9TqXJj*m|HcuZC(NshFnRGntch+Zs|LhazK;nP9C4NvWm z3tz?xdtDnB!waA1j2lFjEFHv_3fWFZC)wOiM#(X>N%^>I;94^9XvCT%2`oIu$*jUt zKZjfq7A8P2_~UXYxIxE|S6^KSi2$oUNd_B572)=8T4T`!%y zG}A{!7z-?HX$C~}^=D5ImN=VJ)x7(hHV5Y!!W9rtA6F45Wxo95Y-MIwZZ5ov$q4R1 z4(ov8KIX~qA;G~Zq%6_}uhg=82R+N`gHG+_+s-Eqo=vBAcq^ySCy0?%f(0ko@w$u+ z0h}ID_AyJb(|}U(?sGfM(zOp|W2~eMn6(Nh8z_b)r^yTmtK%5ceqAJ7`#M(9Ye9L5oxx`L04t2c@)w$Nw2;PjlO^64^^0}ebj?EyWk&v9r$@hE=y3|^%AOQiwN zw@47@?Lv*dBl&@_&|d|H#Uym$bVGe@2li(IxXoOiBNpjZM9UuGL$2CfD0fh8q7q zmJ#EVY5m+$QuCdwO`@EHAbN3KFzAW$I8c`9EXJAXx3gYOm`|t3FH_67)065kf;Jm_ zjvdYOz14@JZjKUk`aeXkqhwwD1sap8Y9c9`dhXT_2ZJ--tR2C!VZp3&Gltx_!q3k? zej*qYGoeGETM67Tc9eR*>H`ejrJ;WuSLO9+Hx`dND5W5{l8C?_D;ca)tEOvW;Jj2$ zI*4eD2-esJ=5X!~WdvEvzW8gAf3}I)ToMOlQe4XiVtg#;qpFz$&(#C&Mg)vrfgQ@nb4mVYh-p# z-XR@(!#bUfhOGp@Fyl?;jfL1pj-SZJp7q(eRw$NJp~>o_OmK&9=fIHS2msi5Q71Ro z?vM+9DO8X@&Cj2A$9E-gQFKsR`LFB;sRI4dVW^kw?Rfhi1HKS5{=<@cEr@m$y?su@EM|Ziu_c`%Ej7h-ve13$*qs zet4C@3OE#0`}(IPxYf3_^X)U+H*(S}uQHco61bEc!vE0YdktHL|Ac=D=`QN0FD|zZ zVk({vuRguAXS{dchQMR6a%{z9-Pz0SNXPh}?U*jhj2|p2!}MGV2F944k=~~VGzk^c zqY{!{8IS|e*p3j_n(+1luSzbXkMP;{&-se0QiI(+%);ScrL#n8cRYZoV^CU= zENmwI4scf_rJWmN$F)YOm2CwHl+H7LCG#9~__U5tehIYG!dYM!KU*%9UW z8=xR=MR^5=xHNQ>X5MZR$z*1b4mDki*CP{lS=f?!wij|&x?bgnK1zCoEbn6g&2ZprZ)AxDz^ zF6PxhrPAD$0hIEob>)w_0aNGL-kc71X2xFP((+2KVztk_SA?VNF)8sr|V5R zOP#E4{|^akYaf_uL^r_l2S8`wY^LY-WJMc!n$hYkg3Vn5IHa^ewho3Z+6gq_hBa(l zSNIa^Sbz{Q^d+tS??#|WF$}(1TZgF1D$`Ek>o00FoMp(4T;f5l$3K^Pw*B8VH)H*H z8iv}vw%g9kO|qP>m}HZG0FBSa`Ll{B+W!i{C_oL{c(GKK{LRX>+a#2O)YACzvyKrn z)u5rQmcprFJV9wGERO>c3l{3+RIvj1s+Q5;`N2li|S~;@Ufa)a(AFS&E>9u90~#La_Rd@Nv;&Vpv!o zAhGZ_oIlScp}8}e13pbg#JX}K`<+L%M%6>TV&Zw+Zc;iZJ=Zop8Eg_nj<}*jgGIaC zFTDSG42^q}i&aACg|;GRHVu09KHj$TC6>c#2BW?n4K50R5UJI{&R-w7<gR%0M+EFLDBvHq&#%o_8tO2>J*d`*1 z90}d^uMr7Fj1K@0CS|U(o^z46pkmn4jEaORl7#gA$|wN2Q!U<`UFC%er$D0kZ0yQ~ zA6?J8K>-es5aEADe4SmJtYUpB7aYz8k2yUoz0o>gJ9=JYa_aN0l%DA4nroDzaDXca zLz-6zKFH6|kK-&Y8eM7nb-c-jipkgjzYY~Xv(oUskfP3()|Ds+gFU`tCCf&dOp3IW z+ho;a*yox=>V|Zf27@W~e|!)<$WH-~VWEm6&JkhH4aY5BO>wua{_X5tBVe;&DvVVz zHVPxJMhbr*a|oQ>z5CXkWAPx)alX*yv=!`>iPV6_6g4WHB?4kUMNt{a-F}MX=($zR zo0wo(ehK9m-)pBe;TlXGZ2Pcy&ERe&F}%ySp_-8A%D2&s=Zc}eXhggo&97Bs zmt!PiFeRxh)PtVzZK9RkD_k%~j|Mti8fP{xr}-Ko$|?EIkuvYLD|u;~d}kADKL7w= zX~q*Q0|tdiZqf@L7V%#zXBAe~0-l^*bAxy8v{`s-NLsZgUy-!ED4oy8+CFMrC>SJ{ z!9n?#tEm>-)2SeFmz=>1z|Ev_`8i2e(!_~?B>65Ubr(sB)Vn&q_}{i3*=Ct5`K4;9 z8*O&vDcI^Of*BsKp`#}9LcbXk?f&F?UZf?n3GUE!F!+0<$B8jpt~JGz#4}EiK?xj- zO7ciUNfKee>fj=RE>)KFR(4MWB%&|=XlfcUs_NNkq1mIVgpj4_&=Edt8Gb!ZwOCIM zq{bMhvS{8+52|fnq2hN4Pd_O_3SVN3Asll1xE(}9m?-SZDwCgNv^z+bv#~v7 ziHp>$NLzB|tKd(@lC#k1o%);bXHQG6_!ITB1WY6NSLfqvLjP2YH~67NE_E+M5T1bX zy1yYsQJG8!n;5cX?}P6NtJM_1Prb1G&(UZ~EZS>ST@MY1@$cBa%odhoJC0F!n-Z96n%BZR4vk# z_NTgx-Hd9{<%l8zaTd!@^EQtwR1<`10Ub=co|EEJZKk)J@f{V_4u-G%Popmrb>@}Q zm1)smNV3%n)@DC{ett?4`wwfN`0;~gM;SiUVe6=-((1K3{GVvs;+YV9i3{kCk#$h? z!=)@kVaf;3NZAsj5}tPzj#7*Tn_rrppnQ(u#3|g?_WUJ6MDViwRaYpiQo=E^7R*ZE z`XEKjROrPxDE@`1P}z0TRIv1WB~yX)dwC3U%`C7NioMF&Mt4S$&y+D?J2kIQ)=usvK|Rx0uvN$FnCtRnh$jj;%%B@gZ?OwT zQb=3UY!wqxleX0-iFH{lHfhjXa2a#i8yPcmtFUXqth-26QujfX3NJ>iJ7+x=SaZPE z!6PV)xu(+q(sQE?gk@$q!y1t;g#&~xh<~F~`n{|?N*8PXA&>wbb{;olw_X`h(N>Xy zqP%+LnCEU><;=0ckA(doR~XlKP#nkx_yTuwny?hjgvhD-A%17VF1NTsX%!p3RB|@_ zEJ(x9fat2V_E4w%gOW~7nV5^9Fl`d)O)xH#M8lRNWtRHub^W-U%4z!^eqq^MkBbys zR_lY+%!JV3Fo5C_c%s)1cgB(|$ zW~+q`-9F*RlH54u&KKfAq{BBNN)-#=kzS`>ZPjG$qexx#Bbn5e_F)v*F)P>sXy*KC z2zoN%N{dg298oO~+KOajIDZosd_C%KT@ssx!qF~3;OpV#BfB0jGb$|q2jM8V*TrcC z+nM>ZXCuQ6QA{p)h8i{4!>kY6x&z~g=?}2F>uV8{z38uLuVv@vIAN-@B2^`a`+ABX zG3%*G8_>rwfa02^_~sGjjK=$DT&Pk?-7U=XHWc=Nd)fKu8eAi2TbH?nk#&n9LX$xj zmOpWwM~Cytj2Q+^e-Qu3fOg-?wT_|Ig9YDA-`cjJXc z;`24!5O<;Q9kZtuE_Q7kjTF%ag+$9D6@8PQ?j&YA^!AYfbMr=&5?;(&>$1(*R!%ID z^P`R!>^fwdsK5POVEkj4tDzyX7GxY z=Z39otMiPz&R;x@4K6xpbg$l%*wIUmjs&biCgwkOkhYd|ze%J`4|%xiy`OGLcOCS) zVswSjheh7%BfO#1rfjLG$AGWFZWu^g=m0<1a$C8-f#@qGZ=3Oi9~|FyKWZoN=g2+F@4zw+zG97oJ<=kd*+6K*M z#x=$YsYA=35Xy$TwFtIF7C#zjJvHec<1#mdfn84FCvAQoXipicH0jNPn2*)eboUy5*gpoZm)X}7h-X3IFpQC z*jLV?3peGJEVG9Ya^BOkMS0X9o`C$h*vijhEw=@`QX4tRDYebJ>@C7?EVOh~5&{qU;OeJ{81;;<~^hnI|R@a}uKA=dAcudiN0+Ftrz z8E?G{d!Wq^{m+lr!w*shVb>PhfLOjC;BZE-_#A&1F{)+B*;kKSv4n-RL7t3RNQ=fJ zoZFkgE?oC(w@$WoKI>#>p(sY@(XQ`()@5O$T9`Qbv*zT_;h&$3e*zBxn6$KuwttZ* z7upw^>aaS}w24Cb1Yb~%{DNFz4r%Hvc1VXf3b`)RJ8~~?#0>0}y(RK0{Pq{B3d4ZL z$!gF*y~PZ%m<@C>2jUW$9&$Duz_2cp)6H!$+JOf0Lgq^TgZt=qP; z&l0tT`QWgv_gR6ljKuew6Rm;$I}D%Ah_(61XA*6$8YhXet(zLn6PtE*8U#gx-k0%@#J+kizi)dknF|Q9YGP1G;Q9l z5%?m?q5L8G73`3|eAQXPTIT`WRg<`B!6q{~^mf`g_#oSVG=r^Jc1X(2aqs6FJ%4+I zn&DqZGZ{MCe2LGULEzowfq z_Znj_5W~g)UQg>!+r6#MWqsd-&piN9GT3 z0onKPC4bd9?*T6%zbOEPFBY5$N7^npTfDbaX=3PUT{d_Pnovf?9pat!R3hal>lOul z9N-tT-ldLq@Mu&{A$VnX-Al1N84S1hsY7IfA%jvTBm^5uSjq;q6H)gt@?;U>??28a z5QKg`+Bl;~Yv`s1dLD1t5!Gv!QVR_v3=B38fBGbSd)+_deWp|od$+CTNr1I1`>S1lX6>M4tnGR&e~rCay}YtDG^7r+&F2P-wg5FmO;zCT1+F>cxTVN9 zr~htvrkvMt0MFy3$eMTfKAiS0hOn<55r-up zvtdVD8aqH3pi;Lh4i`xdWnuu&NzS)v6QkRQN8pjLXRDNNMYw^b9^@wY<;H*>hvg5Q z5gT_^Q~FxzUvUhhJRM#to8ClF?!7#`LUXeLp5R6*?EaRSlv0}H7{G1i)-tuqWI!r` zNe^YcRo_?mms{eKEONT!m}JjV={B@it{3~(DK-&QM1#g#W7x_^JT%bun+Uq8fTNvb zNL%q2_22|6jr;FlJQ4J)sMXYI-l~sMiszz!ahwzip5UEvs$m{1Tx5bNN$4AFtB_X0 znY*k@uBQ(i%%Fg?DmJy*7GUQF7(Nrd14ax0ZSj=nH^TCr$xT$Ec+<6VKYI5u)Tk7Z zC4x}ZA}P&E(K76(( zKgX%HLun#0aBGA48k?Y*YS(UKmnQx%;g{u=P0*ZTy0r z0O&U!;a5gyokUT7cJQ{Q(T0LZ{@AjPA$vd;D~q!$-8maE?8P}`X}O~8%F;c!ybIVl zaHkSj@Ihq4dD}*=WSv2252G(l5H$5d+H7GKa==2*OifU;J>c6E3f0M~C_KJHW2Pu_ zL{9{>pFdr>xK~S1>-*cPQR0l3WFF?vNCyuiW4dtAkF}@R2Vt>A?@2(6Sf4U=MXP}f z!QikPtDp@0Jm|us!V8DS%XK*8db#j} zP>3thGwx3rvN&uaXFp>hfM8HJ+k#!=I^7*M{V4&95%8%AUiZy#mc-MdG!eIoq5X=n z+WnC}a1+%#aiA4EYZ4zp^tM>t#76!-v5h{t8)Mt$kQKh9C8kmj`-&weK{>jnFXEl-UmE-2S-CEsV6u2Z6~v zRHZ(ucQ^l56bH3;S^x8&=^Qt{1a9zl@hV_4KT3OKOo#={pjxY_l=a|HXVr#nT10#O zq!_t#9R2?c7H(8mq#R^p{FZmHF>azn4vCx#9mUv68H-oiLmf_S<7t+NrbtR)Jc{9D zI^f3F8C%4rml$_6LLIx{InMUxKUmO!gh>{PVQha2izU*RVcBUQs_-$=D*~JhHK+4+ z<#hh7Kg*#TBFI_zm)x(*zYl&E$EAa(mDW9l`NmEU1mWca8odstWR{dMhd2PGXvZ#F zju6LUXC=p2=0l{hp@6N{GbddZmN8!f(L8Pprw|H^WZ_x| z3Xf1lmH^J6FBjXTU~zQn%wuuxlE;x#As>tujSxQe#I)MA-CK@5Jj_Wu1D!1lP|;kjYtwm;yi?PIXj+`Q~1GGkJ@H5)h_&9#?GV*Z1TelM1G4(UMTN8 zs)q}>1BdcSU3y)oR(F|$n6G=dA;VJL#zD98KdoXnOd?-01KdDl$>QWJasr8s>qWmB zFd~d(B`J$v?c-QG991=+&!CN^SmH@%6Tg1IJ;>;>4WuD2IIcQnJSg=$t*Fm2Bw6sa>hh;M^3Fpus0MNz^ z{OOg)cmQN`n0Qv6uEp1Ij&TKPW>2GBM&(#~eV9Evc-A?Z3c{6sf}07Ld6^YMMSud; z1FDCX`uRTT4*>RixB>BG{vaOqDbb;C?oP{_MW`&w%I8d3xY zTzi5hf2T)~hu8QpvP3aDw4IG{W+R)kSaOZCJ9>hOd%0th8>wye-Y>RfP#(YN)u{%e zRkFCA@u;t8{y*2>u{hbrw2l>yIB)&Gw4DolRMoZrGmt=#;2AVPRMco=P1GV-Xfp-c z3{G?gClD}ds8qR)mm;;6+N7caqLZ{thXd5wR`1nnTl;R+wqB)b+dO~(@(3VLMWdq5 z7?oEg0g?Q_zrD}of#B`E_w)B7ne*6ZKh|Eaz4qE`1(hk0`Y9E0qT9;?uQ?A{0U9c5 zfbE>7O^I1}aF+SnV}~=fixdj51lQwo=i!F)k%8y!hq+u94!lz0JhZATu$@EQ&7lFt zEGm$kM|2C8rrJ^o2W&vB66cXsWxnRMQ=WUDzV9YXgJk&5?|9KnB0vpSmN&IZ$LAY;j zfz&?YvAo{b6y?l$1n^LHZAtBRr}j3msx0tgFutER!R$>=tq|S}(^!ACBFp{MRc`L- zP8n(lL&7@gAAVLizKtC%_Qy7J_9VXXDmUj-+>oQ_XmHcJk%m2ZbE5yU_2thQ0IBq0 zL+k~!Pj(sGVqm^MTX#7lqdrWY(@3MF;1{R&F?(f~MSbtEW1D$uB-Y?B3#_YI4&6#d znN%RYmcaIE@}c2TgkCHD1Zo)N7E9G=<3`V>b`I+nFWAXJ^*Cn>f2ZYK%$pZ9*YJ^mpK**elu`sx1V`YN zv(^rPzkcE?r-#7tM>B*zQJdvs74pOvXr8}5rBzs3zhLRfUMI`RAJGb($}j354neG= z|947fI=8+}q8N0-IV%uA$Ff>GGL)dmv`by&ELyF{zvVI6h~A5nb7sz(&e&VZLABb= z{d`~pySP-2yjOmxQJILBiG2cx@4m#H(3efB&awl0ixZo?4ZU0aHnww3>-G3Q)^WYZD<7cISHkE32u%2>T6@bl0r!5Dyb*- z2P3wWZ&~6i9J_=t;=ZPE5fm!9#(wHk7NY!Ww!*$z>+}(;HN=n|E_&YRhAKG6E0C?4 z4Ymki}r}ljc5p{u4 z=BqfL%OHhIwI)8ZTYfP&1f`#-|Qxi>j?-$$LJHjg?qsx#@n|51K@&fLf;&p% zdlUWZ>O*e$TyFP;oXF~6?6uYqI@3Q%TtYjr>wh8-aEQ^WH5fk}#D^pp`;geLZwei$ zBp9zRElP5%*;)F1%81;OWmWrGA?-s~T*)I9+ouy&9c&1+omT35yVSQk=$3F`xW0NC z-?Qi^z)0*U=l!c+3*mONZ{Du5s;!|oT4m;CQS4rBXeA~RE8m2LIjfB$M*3*IuOo1v zW>2q*Yku8h&tCl`$$&ikS|c{PK~ZCfUTY+wMh3sf^jqgr-O;AcOc#S`csnb|GrnsP zD3I-3zH9;T00p#5wd3w@%cFTuh*p5z-nJpkQ>m{t_U^@|?G-7#w^D}-;q!xTH6 ziOss4PrlOBCI5Pr-^eme<(nz5vYqegyPBW%D)a}h(9gX>eM}#my18gMy$ZhQ6}-bM z*g$W@j3ysn@By!2xmU2#H0#uT`uKt?yn+{c1%KkzC^w#7P0xDQ4&>Ne+hpJ4Ybx~$ z?52Q5TI$vGm*Z=y-)n1nih^*tdInItghKjgIh6p)ZeeBkhsQeP*<)5-{RuK0Y!5f>5P6b}=0{u~-Vt z1uM{ndcZn&5x=Ro`D5rKu%r4cgzt8kafJ>&(0y$6dzE+VPrv4aL?#CW0y`FbO|Sg% zhN7L!+?6s}qDxl{8V{;rrHmHLaqhhXc<}OqohG9nn;JBx@C8@76_;kK&nA|EJLr!0 zRqlpXxQBJRNM8BNbW6)j58@4pVc6{^tyLPG->Kiwcvy-WTe{bviy@xmE?c6NN@2ve zDnfJtt#1_mvC^r%oGDh%iC3?H`ar3O9f&-cgOO@=uSzN1Ow)EIXqk{3b@kZ@k_Yx>G>HE3klZ8pldLCFNm39d)nV z7Y(q9d|d~t_IkWgorhUNw^YxG9qv>8bvyU_Bkr|%n{dzePtKN-Nw_Um1Z%8ZK*f|_ zEAFB0Y369$ci`b80<*z&?)Wx#zhASmW`lK>UKP{%l zQiKx~LifeQf-Q$-LOMQ5&PMozzO*{x4Oi&v33!aJtx2Vx2P8c>iiz)GRFSUW+6-SC z5BLcdimV_W))`_Y<*@2J`O`5uJ!#&+UD}^C?MQrEB)-nb6T@broR6<69#vmP7(yqE zjr~|yK?RwNNY$ut-652oRY;x7+L%Zhf_pU?^~YL~k`I5|FxcAvVjU?{TWMkh3~kAG zm}1PkAJG#Tzr{GU$T5nv>XzAu<#8Wb;N5Y%vxQDPpA~iQ=twUM2@k6lD`j`#Se9{Y-U0?J}%cjA)KFE~pq5LW`>@ zXLd>4tXrrXp7b1*0jFQ{11JZNX6-coNp5Cm&(4{hMT@Gw9Eiy9t0iZ0%U@M{t!Euj zj|I6B+s@!H=z;fOZ5c&@4b%0ZCWnp7m9S6dSm!zCiiggTk~SkuXn{(n?o=o+br^Zs zrQbMp=ZPxaT(}hLOI#WDCV%t#N1bg?TDoV3uFxPk8`6aBK^WfG;tj$@!u5RN5)@CNDi(p`ykzS1dpv zKUo$I+){2Unu4B5^w z%XjWDQyZ!);f%&MxhLprA3=TD<28=W99WFH!{IM7B5x@}VNj&twZ_)dzDs1DPXosO zEm8lZ*T5{XQZxm&pWI0uDh5}u7VoyH>2bX*$B_AaAp|^CjZMZM-vC1c7Ly3Zce59#nRyj*8Ucad`9RH&13TvZyofMbc*KBK zHip)Sc6ZG8-W2b!ktLGfxK;eZ-dJAYcWSlJPGIqYaR|xt6wv}K zS;Sb1)`kdBUu6!30~(zT8y|RGoEx` zNA8L=dl&j9U*i$Eriu<=QwF7@9z}_e07N}sbP+|>wl0)T^SFqwW%hvU%EN%bAb^`S zj82y0A1D6cjxXNB_n6YdfWL*E%=)Qayh{;{q-oJFwUWH`djgF%NI(G2i{4-Gq8g{7 zFr%=>W4z+O7(a#_Sx0 zN}+%j)4hMZfs|DQXN=Pec`g!1k)b4$&p&0`3&xK6 z$Verk@+KfoWAZ~^5)68x z5fHO;khw$XRATVS$C|hso!+B;g!A~{gOEiftH~nroIc4 zK%uBR8vItj1oa31Elq!%icCeBKnrhW)iU3f(#PQ_rg zSOxDI=wX)ggcN<)v%Xly7h#`#hr6*W^{|=VT3#8`&K!lGPNt#P0}W1xVH;{sU4+Q9 zSKkz;?^frRg%XZpjTk@QvMNBkx1ODy5uwc;&i942PTgAm2Cr2&5hd8XFnAS(>o{Ey zW;xL>Lh@jxjbmH5orH`n2t8O~CMikOKc{X1e~tZ1BcY|RJF%mbK()pOhAvLRIUH^A z`70gu65-gEsqxHBL}Cj%rS-M-HP@BazE?99w`fnUs`3V+8U1G?1zPIr%`PH36DNVH z-v|aiL=$*b=X!mq5Sdv1R2tuTeJH;AE5Yf(uLN&snz@V{Y#}9J;>NZXHpJRmdq4wz z7)tb$RqT#%l@A33O0C*wv{RU|6BfDblS#WBPcZffMuZMz-#Mu!8m@A}#Mt%iSMS!| zIj-gl)UjZUVr00vx^8v29^D4StMicVnIcECG%!k+XQX&ZO$yv zuU5DH+~sM*{8C%-#$l zcpYvsI+C_c#Lvz=_*S?xBLg-Ndlz13kGN|mLL5R$T((tg;yDEdhZ5v*QUh9s`uUfq zZ;TRwE?S5x!{R6Toqs2yD#(&yzLg`aJLbP$Ms%)BUe7Bcppg18TAKKr332(PS^~P+ zI_fj`8^&fa5|^k&8@(4K8Vd#X->nqU@fUd3+!s#Rxjc)@bRHLd)U!oqXv|1j3?)V; zlQ#(-H9u^YS=AK>zulZtly*TIcdpc$ShW$Lhh&eF+xUxxBxgj^!%Rmzl5o0^{Ms+RJ$&-!i?C zRQN2vxOavK>tB1MPez6zZNs`v`y2_aO)zaN&7)>dLa}@Zgk2in8d&Wt{XmFM;BwYZ zDDE)ZaNU}S6XvIrAKW}vM{xFNZ;7;TqNchj)I@|01q;lNx;GgW?Ce{%^U!$$|MHvU z4nsrStp?wxV>|Kf=H^xYb)*+?Lco!%7+^{$8Cma(P*8MWDTQHoIFzL(rb~~0sNhlE zxR+2?`40i#1Lnc-E#cT+oVZ^O#oKf$gw;fz4$>)P%1?o)YO^vRc$@0B2$h8qLz`yf)~dF*UWyY!lyY;J31e zf3>WJ)2WesMskfPDB|n@u+yL`09>OCAL@U4GU=4@A?4J~@xb$xu^c~VUjQP^9S~yb zI*@z`*INU{d;>)RkQr0#fi3`Y*y3XVOs{uCMcae%kHB76`2)2d}&s26s{iv5>twcSm zFh;uY!LqtTi$VpLW5hcsQ<~p1;c{RC#LRv3n z_j;SR#mbKv>@y^PPZ8BorR~)&@vzt;4ZE+b7({0bg6voe$iAC)sR_HRj5(AO-~hK> zS2@ug&}uk23q}SKhSJs9NOfO3T^+W|GPDhC4`fetFTp`V4YMcBue6I0htl5y?Xf;9 z1D0|4s#lpf=RTL26OhERY&AaS_>r%|`=KqFRmI1F(FHZHnoVfCnmhX$sv$hi>`WGG zFJpy3^Ek%OY__7uB+dQ!gSyX}oduD1&`9^s4tuActEE}Aa*;eongu}8jRzR8w45CY zazP$DLoHMkT&~vDEDOp(x0zxG z4K&4)nDJ%negG{FK3R(=9O1YgE!v?8^A~8m6$K$Q$?v4+O2_8e2?rnSoJP-h8;`wJo`Y21&J=-~_M&NY#R3wdGA14Q*zWq`B zbXFhFK-1rMBR0eojSt6AIVKMXB)3dY(?@laIU(4y ze2_0cPBd?ztN@C->_Jri9g2u(UIM4nSS~7f6gVj$i_o|y1 zNoDWHNM%*>3_OSadm+;o7o?Aq3V``vkxC8Xxowcq*Z((k@?H4BC(+3Ws!!9&JQxYc zsC0+gOF47o-$35Hb8;1f$KHuCxS&+(uKS}fE)!N~|?{y;T*oOF6|gXzo5{20P` zQx_-d(g_K}|4HpFVlU42Vq=co4rx34fq7YNYeyNLAkHT>$@J~T^8>iZ#Nli zX2H~(4C;CEe`nbv%`5dEHA3 z>u6IU&z8*+3;Xz9X<=5nq_wckl#@73So04hvuV9&Q{LEl%&oM8XQP`b@0_W`w+w-|Wqe6wzI_zTE2sZVk{7Y4L&d8n)P6mFhk+NX&k0v$qO0X%`Q68l^}Gl= z)A3tm8A<&42I9cT8^U*}G_bSgfz*dAJx)kJ7p;YU-kfUbXRBGDq>WrwA%lKSAZ7lN z>?visiKzEd#-&tGBC<=FUjsp7p6{lfF5-YL4HfYfF8HYYXP-d_4KWGp^Mf3VV&w7l zavvx$bBM~#8rz<1vbr?pdCqQyd>x`6c)vNd>^uR{vMTCFrOG_JH|fAN3}J=Fjw`5n zD$O{$sf(p7XigvgxTcG~27O5XK=s%7`5y|P2l%9y0QxT;^kB%HF>3aZ(wzK$fRUv& zvpyaf^dP!xY)`(To@jA2Qy2d-(f#0)S{vq9%bs2~fO>m~pXO!*fL4C~N8(4{^%(8o z9_{xe!6`OOS=f+asAz|w#BtL9t5)|QMoWO;c~83RMTnkmhLs0G@W?VvgFT27GRgOd zlKlqbjem5YMtDMc%oRO0{@>~G>-gsD6%Za=u4PtsE9zLnJE4*EMkV%KASZtlnbMfWE{*%NZ@R~Bj*Cy`38NMkx)L%Ym0 zGe$nvhD0tuS$j!F`Z4>#t)JB1YqI!2B33TFxq=oXm;S;9<7?DChLZ7{bn!2b@aWy$ zBQ!dh*2zo0h_Y_&2hNhqxK6J_{^vG?e@Xx9y&kdp*K@2Yq(xU?kv5_~1(sDXzNRLo z-W_z8hN+4DE%&o?JcS~ySMaN&H{Cz27To&L?v;L%<=1HJ&zl>brI}x1Sn42g7-^h# zO@fMdY|~@HG(`_SZ(5u^fZBV`BDX9X)TZ~-qX!}~wHbA53m#J2FIG?$dO#{qAs=Ob zNVUH!Kp(Gee%MIqr?0Yf`zsS+u{Yf+&Q347eeiYF^WUkPRpeIbMYm?+|2{|{k$)El zmqoEgY)Xc7X_>g7d6awhUizkUsFIe&2udBLmnjzSP@{RWorRhij*lZ;Svvl-iA!z{ zI&;d|>YE*t01Osn^vz4U_05seH`zEe^6+6=N>ldo2F=2tJ^UC1SZ(gd@6`RjjQ5%I zHPDk#_8B?6G)UK_Z+_V{GG@9Ok?8yS$y)1)5nXo3AJ6-Q)^f!BY0c90AXO~7eyN_v z?wEJ@F?4-c7yt733VO8IQ`p@El6C8w*K*fG#QlHMH_sO9I7bn9ru}g6`C}$Br7xy=Y zL91g*-#wu{@JrO#Ll2AJL4#@1JKi36e}7)~CcRhxrVfsIn;%1Z`*d-l4xW(o&ibU* z{wO0Ctx3=f`XTiiplCSmkn3%;bJW`Z%^LV6s^~fXx!vRMNt$a|yI>1U>!CZ19{Lmy zErsF_Vitw}U-ZxsY5r{W(c7~G@)PQ#WF>N@D<6?rACkxYf4M$N_Rl1raocZ-NOksamIUst-Tkcv_2+v3T;%nl` z{OM&pmE64zy|t)OO)=d_dD^d#C4Ed4ZNT8CdTrWHoJ`n@Nr)a4fQBR{UMJM7I#d2J zvA;X&H6J6uvDxEK{TltsUVTPdhY2|5j@j~TPms_{%x(h!Rjs-u&BMYVZFeVT;>n>P zK{_L?=%nq{bGq%-@%C=`j7xX$K33)@ginB;v0-o$?Z-GBi7Cur86@>>nAsgLFv4um z6G*TU0V!;=C$xVYSWm*m%v}B004D54tuDxf+1Uaf)%1o*d+e{KQ)x9&yDHb%!7I6Z|{CJ`VnYR$&VqV8<$zy)FT%u>tH3lx!(SIL2G-5=6x3j)~Gh?=hZqn!DTkq%m$r zD>2yp6O?+(0CEUkmj-==MzlXyF z_2-0e*oDi7o$Fq!p^-ETqx>vC@B_7Z0+j#PV6o~-4;DT(#W}L$DV+&;;lIo%V`|QV zUSs&vEfoJ33RJijJC;yKVl89iP6y4Q~`1sTYv z2nFXwoG!!wT~Lrb4WA)i6cnV-)kXmp-NkpIV*J)WYX~&L_IjZr8-J$hNxi-HBc8Ho zNam6cI{o1v4ZLt`N*-%4b(+w_Xwm>h03b9;MOKU&Il0<$`+T0Pqv6wae3v1Qmizp_ zQ@hF9f(zC$U_cr9fGHUBbl`toR)_*XVl-8*0LHIdKPsxp+VzCGs;6`}ocuaq;<3IQ zJn%TEn0fMN{e~})8zyf79vr2la-ixwJB9MTrJOli%qC6<$(c{jf;tzX;IhDsh|_-h z7>ef>=(Sp!UXZPMO1^iqX`M4n^nr)`rEn-Ah)m-s@3eu8jMMBDS>HBDGMIZ{@&gmF z_(0nIj0Uo4z|?sCEK}n^`Q;Vb$kk>>70-4uE@5V@=JR*B{FH&Hfh2*yE3yXB3N7LY zUNOeUu&I?&9TCl&&!?V}(5V-6B1opoY-`S;}S#xS_r%0<7sQrKSF_I%|H2UVCrUk0ejH{5{dm98^0ob z2t87TI~GO^92i48&OIU)sGxymGHep_-K62QH@*UjYl6j3Pdtn^k5$km_o8#d5_=# z;VKSRIZIwg!7E}%4an;-)=0W;#_9E68NDBf`dZoSY6w@YG*_b=SSB6;?UGseBbuR? zawgoK0V<(LFmT9OtX;Q=J2^WTILHYi^|gvv`V|Fv!S<~ostx(xFRQAT?-E>cod%>{ zhJCL@ir_ALUy>^a2l()L8s}&07KEHb2sT1%+4+RQw`aGF>6#zF#A)|k&e8^INwd#L zGb>weW2Ci;ts;5B-m<{E)!!5db1=q@c!3iG;yHd+a}`<7{Lw&Z$c?`@zn0S}a)h3S2#)wLeFs3`in98gqWhr zaAHXKcRmxGB)8!0u<_ze3VgsalZ=76`18Oa4M~=pvmM2xUT#!E$_LCi zayKfyD5vQ7Xm%zFho>W&w~VZu({v2TP)qXG^@bseHqB6RQC8mbO5+;MI1OE-mIBJI z^*iSY+I5~_gU%D+2#Zv{=iSw2WOh+17|xZ(T@0Rz`^*Yg<&6R#p>fNc>d2$%nZuoM z7snym=^q3k{v%14&=+69&C2na7p)pxR<}9g#pkK?7}$(NpTw}f{TOSA4-K=!?Q&8J zpjbpD$)7!I@(XuyusPa!aAlG4QeOuX!@{n$gqgS()^e9p=&CM#pa=^sr)5XKY{FUs zXy&()=4eEWm}9g!TPT3DuZ69M70DlkN5-=!}qkuR}V0!UUsYGIeOJiJh-U;VO+j3;t!!D6m2=G=&7rtnEVtu=}%tSob% z)Q2p(&Y726O)WP3IvuyZ0-P`htu(tjX1)XDWqDsgnv1EXk1|TDQOyiJHI_eMsAcX?X(m(QoLCMh17js3u<6aI0ik&4t%*@EB<%mRr zU-6MyrS9!!7b1^FnbWeW_d`VoOlA*iO7yifra6aKTuWbZk%XKwBW|e)tWWq$yjp$i zMj$Jb*Zf?yO2SZeo-+0vj>dO!Y;?WOOG6>}=(Ol`Z|!Po4Ea7J#>tB~!g9nE+137A zzOH%+$;I=Eu~u$?gfB{7J^NKvZIL5Nwp{wE^|YZjC>tjhqRtSUVMCbsWts?0zxu6@ z=bMig7bxslqzWO3N+5nPl0$9}Y8Or~65m4X<&ur(A#?IF@dcqpQ~Zvj3fhtRf}ZD7 zEPk1Jt~!d-Z>EER92Ut;oGyB&*5Sn#K^M}2A_B_{I!j{%M#W+GDT9>&Hr+!|=BWI- z?g9HCFySmj_44eTDUypkoT`i0xBy8i>4Lb}NFBu0jX5T4NGASHvf?Veh205TaC=ZE znU74(M|PCJvwprHjL71%@JkeZQ}IG7hT09Khm~JvV{*P$JR;}RCDwmYXqZoWkDz;Z zA4tjI19cKEt`%fMk8 ze4KCiw1^*%afvs;#;i?4lWz701g1*GCP(j@4rY*qz?Z}YJ3_z9q1*3JK{+lbFLy8j z!U5z+H+dF!(X1OnA`>HfLxgs#NQ^;C%4A87JyW5{@m6W4CUrTG?c%pV@}R@TmtM(3 z!P-O~1wV}d#fIowO%`F0G^vxb&YL}Kb z>JSnr;m03=;XMGfLUF^fW+gHvKtl+_OwCAsVqpA*qNezcz!px4De>e|c3Ko4E|ZAp z_4L}EMMmnCX|ZOQk&!LmrI>>9A%ay2W4Gk^KCl$dyEHfk9hu zmkJE^Glkl3<&%X}XS7*(6p=8I(fWgSJsOYkcaqz_tk<<>Mi_aiv}1JS(z?#Om!Oob z=Ib8k>lj!jnM*bGQP5H}k;YOC=2k$PU6h@eX%0TdK-@tu^TSdF!+r+&V8QJ&9$=}f zT4O9lLIuklU{;S($gBeBB6+z98kxHV>*!`hd6$S0?wDVbXo2%IR0Xz&Ug$t#QbvS` zh_mW{^3E}QAq)R^QR_I*8;-B;T8+itoh2TQ!Ym$NA}z=?E~iSgcNY!z z9y9H;nl>>y7JY@=y3OX8o-_GK;Fz=chdfcNsYabIs8Z>wSHPm6XG|Dvg6qIf*)*S5 zFkK2(zNH&*rqG-(9{oz#o_HdmR5-4jB`Z;r+t`u`Y3x!O`l@VfB}Zq_F?}nDQZ>@4 zJtVO4Iy*>4Xg^6i-CH^Nl*AtZ{s&W;@(an7PNDQxXVO;sFkQtJKFJ)*&uvM5(fAW+ zbbiueEw~S*==w)MZZRc}&6Szda_F_dY&vqU6EedcO!0S2!%S<;P@aqos4fk(F*;PV zA15iGSc#&GhFe`w?)}S4{uC<3l48>oMz5Y?`$e`+e1bgt;TpdiD z5xh9hM0R7b68rG%1tqZ$$2v=tD)pWZe+0ChCD^LCF6*OftVCQtGf>xWo9j8lI5@hH z%V#tA#wly0;+*Oze^0GGm%mPRA%6!EE>R8MR61%;tYZ+FSyz<$_5ctfytiH-WHX%c z1X(C`Kk4QN!RHa2!td_FYEb3x`S72#y5MQjE0zQ|9c}xgspom1+u8OrdrtKh1M0o? z2c3(Wk`4d)QRhMDhOEOsLo{U)^nioT@f{Ba+dG~;g&JcWr#R6@va_Z>$5$r)UFs5D zmGClkK3A&$AaS(#cPdV#g)P*!$+@)AiAi8Ng}X4gET(ej(w$E11HQr-=M*LnI@6C( za<4ODJ*nKB@9)%`I!>nWeg`jhoAN8o{c8uE$~T=6>zwZk+D;vdCQ9w2)IXg|S2=}m zIWeut4m#6bF<&jUH*YzYu5e=aa+4UgoW4M_)wer^|HO9Z6t?m8LF#>%ueNZ#f?wL1 zw$>SO=+3)q<~t+aGe`XH{CdsJ16rIB_4e+XnyYoU$KHLZX1wk;+q7$tagOtJMZuZq!0-H9?8q6n*XZ`FSTdh8j%N~l**@(b zOXV+$7M!J*!;gPDTu;wF{^{9zdd~4rO>5^K|Mc8Zo5x-4ki7HIxKN36|Ef`I#$AqB z9`|ME{(4|Lpn-Vmb?k>`aCW9n_+dRRG)7U92}%L<7xIQzXYjY}4MM~QOk^czk`F3? z5~gJx{V5nkuF%%D70ZIpL)#f`&!yMXEGCM0txYcTGycPe4f&;^coZmV-YDm@<&LR< zYs$54qrS_iFEz`M3wRKGUWS=eW%}NECM5V(7o01opRU`pOBPiZoT1xc&NEmeW+Ik` zFxP!-K2Wa63@Y7l<~{QYPQS9$sapez&m5aIm6n}ahq>hD^XBGFdy|4loZ8Gx^QP6@ z{L0>JH#ghu%?5KbE=vQrrC`{ze5{c_$K&Ah`MSZ0`OF7D>XfYe5#lvn;$ceY-LVJE zySi`lF8F*2U!-m|#+B~AzQjYi_kd}t0$_79(cD~YZ-VA#g6(**x!GfHE;TnpY+pZZ zZtmm;Hk!&dt%Rt}gGucnj3Vad>S<10N;hM(M(LZnm$@nV!WdPs9NHlkU8ptHY-}hc z40m3^nS@`dJ`IlcbZ);zx&5USh6Bml_E}lv+xz!?zLFIxJ6!Zma@UVOVhO@cYK!UpPl`hYXE=4^cwoVs3aX!~p?tDa zhviqmnMXmQsM$_`%iQF0lX{3D3-L!W`7~xen>^L2`-om}zi?i`uq&Oqyo2idb+L_*f8m@bU=WTCsTWoHXbs$y6GtB#I->diZaB0n_d(r+e3TkQ!z;dX*F2eVz z^QehAtds6*005wBJH7Foe&qzG4%#xL)Wt)drXCBGfN0 z9gB2zY@oVZXuEr9*VBl)yMb5C=}kO!>K>!-sii#TYp1K+E|q)7g5ZOnq(P9Ur_1=- z^tyb4A>x{wMD$%f&7lsjrZax<--y+aluX*YA?;^gD;u@_trnq#(nWyg~;tcz=SBK+Uj1D84@x4qT zi>izm%nozMNd1cGX@!)JfwZ|llPsltq*+Sx+Qd;PPG+CmGrWO~Hgn~VP0=~5Pm{@W z%(Y*i6{bJqI23_VSRrG}qt4+$_5k@s?ZMEjqf)h-%)7e!xnoPovnKDjMaOug)l{|# z-FymZEr&ZxNRg_}F&&-HBFa#XY!I`yVbCov0E*=<=@%?!>s2m(D81U)jkce>hi+;y z3>U^5OhobY@oSxs`)%`s-e{q(#m^k7wvA#F3`A5&u z2aQIrKu~utA)x@PIpUHS=jp5s_hV$}gZ6a|7aW$K&F;e(Ki8NCh=!DWoVHO9^MlWo zsIP2D#yU!5f|5NiA5akPXGai|$pPo0M!F)ih};bZ_gAMT(kU|x!nuJ&p~OHF+U>7> z5x}4WG0D)&xRK!{JK@APAS7!4lLy=vV&s)2Ki0u+z~`B*5V5J3jNqaRP)F3T4Najq zCVb=%5O>$9{f&yFz30VO8)$eT?RiIb!rCwMR+$PtD>9$u@p#eIJT7V(wYeSBM!Yc? zXm^%6YOPB2iV2wQHAQfZKUT1iZk5K5;!UAlAX0yEAKyY)6SY}QShjrx6pF_GVC-H| zT$6=M>;`F@0#d_t6TwSOyV^E#F;?ZLtl<@6DE2mkFuRg7MWrb@LnUNJlKpFz-bkI* zn@YVgJ09_sG_i=srU_n^r#7n)xU3Fp+A(;(3FE@lF`6HuNGj(iNx)vWwp+C}`;^)J zXZwh5L(pR^MdkF|`_YW+He7Xo!8%o_XohoTt5&0v+}tk^HG2D0^!nF-0R9*gQn?AE z+roQUn^x;9y0g#x+RfSI^uOZ7YdbF6e{98^pqra1_VojBSlKgGef))B{6%9zNn}GY z)uE!-K*r%^RYx(MV08g&|BY4y4Gb@_DDH+RS_wDK=Q z{jFzC2KBQ*A3&4GBHW7X}arVDaCLGU8WlI95*MASfg)GB?7qvsjk`h8m z!;%C7@@FIu#gAh|rSu*~#NlcpY+#fSBN{(iL$ZwM0v)P?5gE1~>*#}}B^YR)cb>rs ziM%|8SUViw;4J+of~;G9&&F%VW(a%>XLyO7T7$l3%gp2^30e`H?t=&@n~aa#x7#;TsMS%uNL#(nYk^jMez}qw09$!|P_!3rp%p%;Y4}S|Nn&+g$ zaK;=-i#-%06ewGp*d3cjZ5}(lAV>M`&fDVDwel`ng@O86E;0ycMKCLTxDI-ec8bI9 zL$hQ@BnXV2k{af`U_i`awdWk>FD=c*%!!VphEPVOM((*=q0fxb}~4kvU!-sLfPawjgZaDanIVH}X*BgWPqtdESE z+CNYtP01f-N1p`~{p<_wHBDi@%Ae$hYz+BwgwaZEtd^MRV}sI6o|46)oUm9xmWShw zM(!9WB(KAn9BHJ1O}jyrm4|#s#HdD&WzwNsXK96yK0)#^dD}v=}bq*$NVU6Ls?C;>Bk-X@qs_Ao~qGL)^{Zzq1zN3c3=e#{FI`Rh|Nf}X@ z{Y9I!ong1Kz=J|}A|6~vW}m`V7CR}xZ+3s21J-rm{>vVqMd|Bo*gQ0o|A@o$?U0=( ztgMrqo=Ze(1RlxK$D}}0sTp@sQv1iF_zhO@jim%J_TSJS?WKw`qOMJ-mpt&K!OJ;z z`s#upIiR}5B==&9qktKmrpc}7>m!?HjEmf}7tL)Mb3Zl@!{j{pXPi)nV zIZTh}NF9&b4~tjQyS{>WJQZ(B&L-d3aiR-`5@-rK4`c1dxhuzcq&|3FQ%aFMm!%u5 zhvTRDhxg2`dZ0%TxCa|awNf1=t8|Rh-Vb&ZPb*cZ^ai zg;w5qKZ1l`z&9*a4*9CHLhktY7)pdF z>)L0XtMK-Fc#u5J?CsVT=49T*wyaYC|ADToMu(mBt?8$)g=1DTTy72%r~ zJ=G`g;l$_ygw|v?)YuVz06clSG-t@{WOs!xhGD1m3F9VF8<2j#BXyd2 zvCuS*n6WrykO46N35^}`5One!v(r`X4(S9bs5P)`JE$n51X+9FX}#T6u-6{Gfsghp9O0CbuMPbH@J6o7VU~w zy~NT*m4TRL7(W7y#DUN*QwGZk zG1R9t;YPtC0zPaFr?!f19aH&xsDpzDy4axG+%HZI_vNsuNlwBR_g<8$MfeWA!#A_k zCdgpdb(7p2JO`x!?%dqjiG$&jvr=}X^Nc|E{Xr7l~iyvnX5qu=^TISqcz7?qjo50RJZ04cwzq4y>bb%91KzaaSku@(ptg2 zcUvZ#Ji_7;l|T*mSO=!*ja&+^vw!u9a13k)$JX*;S$vhjt?^ugTUYXc9qP(yCY|hRRNuFl6Pn^UF~i9W0uT2H(B~t71-f z3L^Y3ZE!kwUco$S!ZL>@Dhy)n0Z!?vL{|o@44%z3_=Tg~2Be~f=Y|TjS zb-{Q|sqyj^(uNX!G1Cfv{WYgr?!2I%ThXU8emdoGoJ^8&Nr1W-A|_Q2K<{! z_LT)1YEr>Cp}|^@hJ5wGKu7htjQ1*c+)qPpiO+Z4(GZQ~a3aSyjEla$>oOVJT+1}x z!SsPq?7Q>3NQHUhSQVTbTaHwL%H*0w8YSzsgeQTAx;cGsxG}J4!EG^u`1u%EHmk85 z06E7*k$>EXpy5pW=z_$+)E(#mUG|$^`2oL9L1V9yxIz3g2OcJxqhoJ(<729Ju~<+^ z1}YAnDpv35deJVrtAH1r+qIojbW`YB(yf?BA~F!e@kLzXRxr|s=9%?U*Wlj$o(5+Y z|4cFLJ6h$f6=()Nnib=N#DFlz1~aKEz7|SE8`)K~%dQHIeic7pa3j8Hf}4Amaeq5Z z4@iS$9IMB;cR?P6_QbDOkypk)!TmL9B$B}(EKW0!)!ZDtF}Nk{EZ4GaG>?#~cCnUp zE9uQsCMgp*HVb+xm!qce&+q1p3~X|i&H~)w#P9+jRkcRQZ3PsR`x~lCoMrnBp_0Q) z3S-vKcwBVAJ~r?IZ*^*FlO%SDV#ACc9Pw?LokOC`-6(?9A7or3E$~0?6e#2E*Gwf# zMFpMlaRT$O={;iJb~tSWPKI&}H!K%rq*gNTX}_6teu@ot!_XWmS%Ecft69FWVTi^x z=4P5=%AqsdZ=>;?f?#tg13(Ks3PVJE!5eEa?6SAV{@qB} znJw&@6&U8YZ*Zepw3>Q0o13)#tTcn(*$q7CWOx|WeR!H_R?v^+8kz*~o`+8GhTx4& z-TIxXWCHAd8uqj9{WsVOvjH^6JbDMUTuv>@ESRG;S1Dg~m!!yL6p?~>cF$7hQcCsn z<7L~vo-1pQ(sQ&SyCa!W9tiI_Tba@jWqlElOoj-yjmA>KY$(Yu&hP^K-)YoDPTC6# zSFA<%Gj%-Ds(5?L*o2^DRg-D|<2wSo78 z<%Ip=bx!liE15cUK|cL2GO^OVic-!B(?f_b2P>mWuRW%PHR9%^?Gid(ABbLTwbhFfFD&U9~k#F@~b zi;1nygiYjT3bX`qY*T)sp8l#(a@LIoO4~exxKt7L=ktW-Hut)A!tPRcL0~9;Z+Llz zKO+Mh22U~zkkkJAp&+I8t-O|p$)9{1mnE%m+LP12WiItmRm*Z-5@VfA>*1E<`L})K zZ7a*nxHtJ{O6vDno_pEbH_jn@d++fo-}-`y;i^;W)-1T3?6K8Xpqr1{tYhd?YV5)t zMWTJbQVt3}SXWNvfl2pNu@=w$1~vt1Qn>Aj)!7fYVVkZ6_2lNwzyICuE^6pJH{9?} ze$kP5vzt5Bx4CFLTiUfpC{1nsXll?~)%vmmul~xcBi})H>GV}!&dX~#-(Inar;V}B zKGmc21VNpC(zp6tJ<02Sl36`SPx5)<^$ll9%)}WO0iUHSzbje|BPIoI@_Y=9RphcQ z{LDmyY@w3Am`FA#*9VDiTe{>caaK>`-$XyjXE`+C|MEWS-parAe9MW2A)C40O%GeS z=LEivDOYkzf5;ksIoGVi)GyXM&1C2F*Y!ZBcq3MvZjCfr#UWX@`A7{y99;|fw ze;3o@B#fM_8Wl8LJyJD5r`Bpw8#C$--7zpoGI`{s&WvM=j_VAM*?%Z%cAhvKA{ljA z)tWNA%86KxVS{t4M(e-I%~?Ik&9pAE>G{M^?++`_X2iFTa~G=_MMS3$A{}Ah;Xq5x zt4fU?l3&lQaKNTzpioUBzAE-s-|DdG({Je$aJvXltX90*k=lOei4qA<1BjIy(7Li? z$NE&~F?G?k9T9gNt(cZ3tEI^uv5vkAZVFdzK#SzN`l5Y8#)f2{h;KDAGTy*8IBQBC zX3bniQ_((t{^pwKxYINIYP5g`r!gCfhfw(f|6ZigXojD^xv;kS{BU4(&5EWbBQsLf zjKszPO>L2`)lD%omnFVL+Oj*tRi{O&GAx%MAZYcs>NX4N9Y7r)a!wPNit6h1@GuWo zE8Z?<0N}3l%LJVT(5qzd<6zkuQ`nQ=f_F&=rOE2Z;I9D8s{)5>lHklj;Fgj8#ST;R zV7Q9pEFD+JKZMYJSP;1{*wA4p&3B~XNFNfVhTP1p`Y2e`65^E0F5C;bbFYIhZ0C~; zBKKi*gfO>n+RG>J^a;6BNoMBMVmrpefP9E8!ASSpeN}WaCmd^@!_Dj``Ey&nGx)}3T-*ul{avpqf$+mw@@XjUcpUl0{|ZOMAA}>qmE-Xw40%kOI?C;>uw2eKBh`)7aI!kV*6d;Np`N#To>(-$h%j==xo%7qy@4;X9 z);EEXri8}~O_>lZTe$e5!Nt`E7n5mRoa|;U1P=pYUwao4rsa?SOZ4d!&=4)Axt#0U z>-jUAKhrjH@wFEI2p6Zl&&7?c{JD)k)86Ldx_x@bpJ}h~kC@rrqlSIKtcJYDGja8m zddELPiwxPLU;d>zJ$uoWjXcNVSlJli@Lk>4z}rxKt+0CBeLl7$*H%vfkC{>(aP`6N z;IU>d`Gjiy+1#A!U59lui9hB|7`&b~i9eP4ssx@n?F#->HZ(Ochq#=x(_quF@jALn zwMKQEuCl>IzA)SQ0yB9Ytvw^XUO0q`IQ3RAffa+XoOA$qS>|R4m(kqQdF;@v3?k~- zsw7L|OHq^-<76mjBkjRp)MNknd6T$Wrrt_ZjHhfiJa10cCceZScIM7x0uMG*pOIv! zIP_!fH|R%vMe>`xgG7}tv-TIJJJ>2h2@;lXk*-}gmU{6zdY4!F&)BTY#!GRp8bhdA zEIr43hH68Mq$D|%iWOC}L@NffOY^Nhp{*c!09F1 zPk={qsKUVCvqC7+ZBuCSzRKij+iKIzZiq7A$G>jYU}gq-G;Nzr#&GrPHS)S*FuA(| za3wvDPg0Sc$4MXiNLd5D${B7(YCNRp-Dm0kGu+GIfm`L_G>RJd%=`B=vIBvjGkHs3 z*!-`0Uk=ij2T#_W^SZk84^B60&hL_(vU8TkF=j6{zPoRysK%dhZ`=s}#D%{5Ex+>h z%X^mB;1n@3>N;`PGr?8Z(C}Yq9B9x2-*CRao+3`2wo*lj<&2gBg!36ODEu`Nn)buf zkm|U9!Aac0Ove~?LsQF#$2^M17S3Fab;Eg3~;YdYRVcn*&1LHo;v}q#y?HDYAMNFIScg-}^}MPzJ=b^X91ncr zC;BVnE=2P%x|r5{z0M1B>%n=FI~tyWG2t0TgXt1EtD_y*vR)Wf&umGq17|c_$3ITT zTm)@NsV->~CA{ZuwwZ&0RP`_fq_RKIc+M8o%4yM+On`*QG^EyuHl^j28%{q3oQe7l zmj$-f+!MOc(!CH`^Za z#7tpR>UKUd0GFtU#5W7j+A={tP&+#pTeIC+oj^Q-UYrJDL?9%FlNKm;H=Ou726_y} zACyhfolgF<_LitSd?g?PEZ+JPGc8!Tv+EvsR)3w%)`3_+=^Ka1l@D#2f}wIc_W-?L zE!{uKvvoja%bg=?E&)9qbO(U4DH>?5c|O7}cp3U(Y-M(YFgXvUd{~Ck`Z^(b_*N^w z)orV^{wRE*?axl#65yos;dvoaK?T!soCq~y)z5}Ked!|WCRXV5Y}6t4D3c}s#@gQZ zW-#zdO)~W`+d*1rd-PCB_%sZak1|%e-Y2+;G`H`{Lf{9k)FS7k_zp&QDZtC*6sSRN z?#F+jN^I8?%o0vJ=;H^G=2gs0XKXd=rnl)!t~S!M)luR3NPVqJvHe?xIgIgFJGR`P z7WNq@hDx!xLKUASw+5OGv!S%mbf=keSFmTfl63?gPTu}8TX|YuQ!g6}9ZCl+6^OSo zXz_(dAT}Q^9c7J2i7b6EgIf&plwD0(h?c8*`_)JM0D)SwhbYW;5-9{TS9_iBUj^sG z9>`xqSTn*z>~d|6l^*+u%8(fa=?VIE}!5AYjl=H#=KkBwkhhu$+r3{CQ@;AVz) zsnqG%yn^yR2TCEzfd@j)v=^Q4?t`)D!C5Nu8;Z;bRF_T&;IC8mQW4(Tus@>(sf#c{-AP-$o*4Vxj+;5=V)0wZH+THxQ{1V3+3W# z)tIlREqcNVy)_&-QuFIjz{ak2YM-Jr>?YUq6RuiIjE+;w+{{yy1tuRn$$3G`r%XK7 zut%eNi(|Z?KSFInNr`a`?iUQKpZ84+C$Yvp`dF3N&&(F1`PO`6qBN*ZeQRp!s$lE9 z5t#IeD>0O>PmB5*1r(CZy3zF+y39Su-^#(juyPkygU`@*LS>L>G9+v16ZX+v#T!|u zVX#dyC*oUM8aV7My%}kzb1#}c%~4^vYMUnbQSPJe)dZ`DSX5UD%MiTPEWV`e@?qt9 zr^r|t}7WoiK$tl_e4zjx{e^F%uXB2Yy#dOL(jT*r-5)D>&U9tU6! zZz{-7Zkvv6Fp+icjYetUiF6HyY72$HTz$<*?dLPY&aEA(=U{0T3>TtGUFGIph(89H zCx!&(PFtnjvoJQHHjS7_K$JJ5ChSRAtbhhIYSvEp{(OVCkg>Q=Y5bKkcYX&{o)47= zH@%ORBE|%@5pm&N66-1dxp)(Maxk|0jhq!zfM*zfO3mY^-XOAFDY6wasAmAY{v59^ zBJ7vpkYTxm84u)4BQ=mOOj_Xwuu+|WH%vrSO)q4o5myuoLXjA0`H(iLX}8=mBdHaY zY|+4*X;64)`O>3YrSZq|qZW9JbOd`=vaF{N{5ppGJ~g*=o(_UF^u#v3=g9h96ZAQE;)-@i!9u#E@Ww2d;o2Z4pBn z+QpF0k?K;+7B|UQ!#)}kXPKov@fS_k*^?3F$hDr;i|1dwPBPerD?OG0zq{dK3 z4~w$=RU$;{m?&LDQ9T4=-|dkKj*a$`;G9$)+Xh6l4d^;AfedBmTvI z$+39sX)XCfZg3K0`*vQ?>{)96)-0zvqZAC}uzxFvO6FDaZQ}DB=d9bn6R)ytF57aJ zd3Uf97}8UwnY1O~{;$wn4$WZ+Q1^OR0=n_p`yMvO=?B&?-3xlg_xAPDxZ0E7+hZ*& zQFwQ+0(W@@W_ks5P|~YW<4xVnz15?=r`kg!w}8}hYY)`;=4gCGU2tk|WmE#rL`ulG zIDucYPzU!g*ZBtxsx*w+e`jvZX;L0!{DN_3JBck+-K%dG*uH_yIQ}J9;08wpT&gOy zaXudi@=QV(kR7v>hI{ALt+_jgL|b?Tup4HUL$;scs$nXvcBxLs7?-4ww)CNafLZ~W zY3r7wV)CHT`ToX%(r(xAmtDN!EEhzEERJ%GR7~!zV84&<0C&4r;f-~K|IYqSZ7CSO zELwF_fqywr(?s+dUnztsxszX3w}*ozthOb)`g(g2e*p>8A@Divs=ujft zE?|ezR}Er^;T5ozP~s~Z8A7SnAYLd@C>zL8=8{s@`Vn_tfpTl)m9kvaDyNW% zGAol}w3|t8^_Fa{Hzv55MIpQ=_t1UGMD&5XkeT*ykL07D{^wogvX=FhESI~X&tzbF zrSQl|)kk*yVUGgZWl2?o*h@LXkV5Dxycu;M^|f5V!pe61IHNl_KWSh^p^D~4sydt> z)koTQ5%J3`M$T){YL?~Cr5%f;ZwiVLYIbw1+5vmqVY;j>Al5?)U&v_l(MND~){0dCP;x zcpyg}E}!I5U&iYD1_=RWJxUd)xSkhfZqB80iUS=Mo0F1d?nHJ zNaqnwg(tfe+bQ;#@rBm97oSvHj5o@4ZKIwcqBoiwu^z3p#KB|^0Ki&sa*l;yr-W}P zF$RXw4wCR7djJEV1_a)PNQL)HN3H1=r*`RxqK099+8d<1AEkHd7AHcv2B^H;)6I`& zYL948hJGprN!ehtW7bG(OD_8BCaWr>YSmP>n3~;sAEdW~)+=J=H*Ms9UAowGe#H)Y8fa z^G5Tv(4k&mQ=yqvpZYbL4sB9D=z{uWR)QPU2N(b}$sRO|IjwJIM6oc0ubY;}1k@E-lK=f~gmV6Z!A&x|WG@@Ay5~+tx68dn}{)l@CJl$GEaU=Vu(JBSP zB)y#E4u6v$7KFJ?bl5Ns%C_(buRyaMBcoF0LDgVr)FbzB!yA2#{{wR{v4b5s4zI{) z^g_2Cs2}QbHje;ZWeHm@gG<=F-4P9}s(D?zzrM9)z8yIE{VlZ)^&l;u;FStZklJZn zf=e>oaHnO}&J$~cMXdYb``|FckxQ}-GEB4n0aEGv;@!epcke8`9Z!?n{w z09M-Bk$iK~M_AWAhMoGL+yB_9{UW_doo}9mM9r2h>x6o^%5Sy>@5!Vwb~SS;X(UJp zhp@?RW^>5Bk&Wze7NQ7}JR{z)Z)_Ee!63usB@?1mp4l#n+0L6Bq>0!hMEeGDO;_rZ znagCQS+bV~S-TCy4G~IO>-n7s2`4DzV^71~+nNJx$rvz&Yiy%|W8sc6UrQ+PYR#Wg zGdT32?**)5^xpt$QWi@!ZDXDe)Z(jv8_nz(wRzL~oDA#aCif*R4L!R|4m8U=56&4Z z19v!Zpyr);L+rI<6R@uaRy(!77FenpBLIZXcr%~+0Z);;o?e24&PY9{?JTPhjzsoK zEH?1SfHbWl2x#C#NPaoalArV12*umzF{=*Xc}s!+a(5hbdlR1AS|D3PUeGY@32sh5 z2?$&{;HJpWuy1|1Y9lgBy9G?>2CW5+bh8prUL0b*Gs5k!Qp!lLs2kk?lYUF5p?Ou} z&g~R5xXi~v+)TEfm&co9Zxe-pwNQK&_gGAQ4e$5is?x|YXtIRmXnr4N#6LO!Xbw8x zeV&=seZZ_<#m>v(M?CiZA&Z>ADA2r+y;yj*Bl{@J&rrawN5{fPjfKlUm9?f}+Hh1D zH1$nwHT)Eg9N?7XOuPr+LRTxJRof@K!}(V* zG~#?mvfw?@$Tuk(!k74@MX`h`lgqyeFM#R z7ZKi8V7MHMki04O($cii3e-OCL&}NgHk$_EmdFAf3n&b_^Ra-fglTG4ne->x!WYhe3= z|JUC8$46ORiT}^cM2Qe*lA3B-(N2}tq+(1cAgQ#@gh`lz2}FJ-GJ^=k=Po&vTyp^W1aJJ@?#m@3SrbPqMCt0J@DZLjVcmGkPh4)@xO=5(5u; z1JU2HW>XV|;I&q|?@z4R_&5I!i_;(T5Jw_<;7=uQUV{d-x;oAshxhCCmV0Pm1FamALx|~_DagFXa%C1b1UP0{AZ*LMDK}zhLJVYG_FT9 zgxs3=FR%?rjjI%l;{OugONXUR=4GB`_MfPa>jbx6BIGwfzRY3f63{xcsko`MKe2J; z*4h1UZ9JDl4%rv7%2w_8`bhu5-m4@DvnT7&6d6Z&5Vahu)U>(w4E$q@n1O%wF*%RD%xQw zUu{PRoF0l*=c|d8924b(eRtt9cQEMqQw=-5`VK+A(pU2s%**d#=KL)Eb+0n1eUTcA z5b=sB7``cG=qUaJ>c%*$b9_^P#ZT}D3MMo5aP$DS?P{h5=U^Cw$z;TN7!893?)!S5 zyqMFPB7MQ8Wz(jM`dLaLfqjtpIQ%B-CS-%DTbRt2pBxiN)lTd$*^TuVaORI5+joew zwFP$~l$nq11Az!;Bfa!+Ul&`Of9Rvs6N_`5;|ZFLQyR`DXvorRzuoN7WV1KX`O;XV z+Z(J#(d49@E)wxJlbvg-b>fd%aE4ZO9u+ygKTvfz@(o1W>AHD~`M3#%teC`K(WLkd zv@Ru&gie{QVT7S7)Q?Wr8qaeyTT#)WpQUlkz}86++K>pnJ4mJckUiUFOr`_eio!T5 zNbhCBG5N@A(R*ZFyg#O6TyRw_3LJ-m-gN4BgSvgp+4tnr(5DZ5O6!gGcd=IDpH+H* zpLERAqN^jiBj;1j>Cni3LnDW9<&~4hN3KKAtR6Ayytr{aDN_D1jvr@{WTo=oCF-da zy2xF!E>AWWjMT`%xl6>@(WOnjjv+jre>Nr)hoge#sn^zc9k!vyXNB0z4M7i>BOH}1J4J{c@U zE>^DGObN96b`VW#fOnIDkb{Wh$*ebJ`ft;gP2iTE7(qeMZiBmy<5l|3C(B-s?!j%a zY=881PoMC;^6zco21a3&FCB?8t1W&+Mk)^HE%KOr3NSVt z&AaKV;-0Ns1e5OBvegQz=;J6DCWU*ja!|nVJ`P|A>=gz5er6dz=Tr(A&2gebsP##; zr7Ep3b>SK>oQntGJ@q_@b9Q0Px4FR2+ph)gOtq33hvkWD0&f< zj2@FbsQDtq+i^m_jN~At_i0GRm-0(~$I<(Lf=x$p+w)_%ZcALYeED+icY4?xDBByG zd$YgnFM;T@%D1@WE!Rxyol)`LQyq7k^QFn|zf+qU+l7uNVS3j>p6 z1-)>pQu~@MHScJ*yvVs?iw}=YV)b-Vp{J;Ql7O`Tc)$`$s|e#n@*k8Va1NL>8H@G!# znxZ`=y~Rey2~AM0^4lvNd+?!jo4r0f@?$==F3~#nZ@gqgV9TFqKH5OU;9ZD{SBSUQ z+El(I45NY#6OsJ)UxH$D4TtEiA55=?r*AnpNsB1{JIP$VQtw|*NbsDr2_$Zn(>`uls!)m% zOMjr?9bPj1ELCc=?UX2e!q!@G+LY6RrQvE!bt>7giMM1(78%u`%70%iRo1mJ-7}ra zq@wBWx#0_@dpr|fitp{kVMMu3abc7ELHBa-(se)DHGxm-9(^0Cr zlJlLxifE);Reh*>-?vVs)<}0bOImiIZaq^LN>1YmQ5=eG#7Glik8P||6yg%>kqGcN zrFzJ?S81_Y6JfrCSIJP&_Ke_o4;Ci!oGd!Z>Ia(-r6Z-Pb3!qnQmOe9-@NE?t=F84 zBC^Z#)$h2)@c2#sl?&(;l1a_yh>^WQc_}DYA~b#L(3wejCF{#|4$RcA@rjjf`zcEF zQ`YsPk4HzycpnrJ^qt>9xLL7)2X(od@Jt5SdVFz)p<6Tj7E>*S+e;h2P@-jB)Rb?Tq%sDn$2H^e^_T(#;?<$ojc&YaT03 z$3u=|94mt7@bu3ZmcuD&M zP9^!+>b)t#5vuJUQpB^>^7I{rBLX5<>B$PQYV>^ynIYu!JTqC5^h46m7!eWsoXf@t zbFL6oVC(t8rUT*`bL4>fPTW*=5D`Y9{ekGKLKirh9N70NLoCX{izr(o0u&;`5X)T& z=c9$oM#O8hRGz&&FO1#zIPRIozmIKT($6o;RJrf?vxL1An zEpJF7;L$iHrVON!+zmUpYp1f%smfpt^eIN|R!Cwu?!A#y6hYF7m~~#gX_Vsm5 zaDeT7pNGyxc|4e|j~C+RqWqU0^%T_`|D`Idthg;RrE6C;R+e3K{32`f+-aP%a2k0A zx6;X=a}9Gb+%#FY*o?0bHnR%sn0pq)@=lYt-a5>}hd6`g9^6Ua3iI8^zVFiyNqVIl zaOYKvyE3<+8L!@ib6nm`l(5sGSWf-h6=q?GBf9dL*VeK)icz)H;n{LAx6&?{UAu-H zRQ773)+fN|DFz>uUhjc1;bK)&feCj0V6-Z_^`fa~V zEg{HW1EI{IvYa1Pc+#?rIWPv~63!je975i$b+Pr#aaQp))GIJW7N{4-KNBeO2TjHn zW3hQcLM2Nx_JE?Jq`WaM0c+`iI^H%X(3E zD;Se1^2(>ASKb?(eT`V~tgKOUpzV`z=Z~#UFwODw&E`J(WaZGlm&K4VAnIf>Gr>X@ zj5L|;XXci4*p>~UPbqJ=%`Z429}`1eF-}EFBo#a^{ZcSQ{9TkKzJf)0Zv;30iN%hG zgXd%B4?7OWucn&}+v8N==^I5Z3vORgD+`+I87}IgZ!l;Vima!VXMO4-6`rq<$5cvv z^+?3N>P|0=<`ulfX08^o5NjU?ji&cY^`bdljmuL$NIZfo6U@3O)_yH(&&Z2VY(CN9 zY4{Vq5ca%}Gf()0Fo|eM;3P3m-0S)30&wN&5AeTP>c(qvHTQb@E>x9YCFDlVb)1u= z{flD7oWn8ou;Hh&Bd}BuYj@vnnx*A%IzI`AQrvxd=gdtHhO71mV~dns(C_&sY!!#Q zhHCP6!J|h!eOnkZ8GbxlzQj$9_>h;5Rt{k*M`HXzPZ)fZBHc-+&g53DDD0R(`a=`vxV9g4|xUHSYd+d75Y_F^Js4!J^RK76g>Wlz8MMG>u>5u~Ed z@kX8F&7cDu#P2pbk6J`Jjy+fUw?MYwG>rset(-7Bu2@I}E@aC=9%}h=NXVEWo>P3D zls>PVg=QdMrjovy!yHy|5^v657+dwMlI0aaz8MCq+>^;bM-7Paw$N4*e6|!0+TC3* z{2`}im3VGF&1eU{kevO6e?vI>EQ_&k1|8@P*veM49_f=wapmsQY)W-M^1d z?B5a9zt89D-vjT_zqDF&!%*Z@A#F?n+9g)=!-MF;p8osz_iuicF$H$4EBmwYF+|j< zbIsJK*8eq8De|$QYe{;XRRkH$;dDLESA+mAOQgS$V69s}8;BN6L(Mp*G(+u6D%kd7 z(S^4Q1F>~7z?RBVfxs*1S49+aL^S84FRK0(6;;mi-@XrhRk5cO#TFK|pFlJac6CgJ z5Yt7fmYXg<(;`xH{!xzb3zQ8jE#+^>CKOw$+=U|kn&<2ve=>tkCjJ21LkqHv^Dz zP#YE|X9R?jR^}Z5qc_#*m8{K-xkN;G7tb|XkJ1m=K$At^foZh9vxbjR2?dZHO-0|K znOpOwA(rQO`gX`E*ix9Z1`nUN>S9-Oe1Hh$ytAd5;y7AyK6;S@0$7FW5Sw~0-`G9N zLc;Dnbed5&f}#a|n~LlCg{}WQN15n9_uoVX0<$>$yx{DR98>zOdyv#h0m7tGf|@I< z%82Pxxs?{OJegF0l;K8gkUCNS30IAZ{zFqeecd9N9q}Cck5n+J|M;XOY!49amAev= z$%QCC@oQi~A)GHC*1Q*N5;IDn%+Wd(2vIB}FY_~dVg`zQjH~u1-bGV^x8`W+Ehr!VhI{u>>7*91`CPIe=YwC-5-HReI@DHdoO4Rz(*u53llQ|Dp!k8)g!&n zMxSJJB5S3POuZUTA!sHcw6<93M|ndC1bo7aoN<|r*>#nALX54<3MLy#yV57t#FOKn zhtZSmC!YFvY6Y(X2lDj{jzM^9SLr!$hL80K5y#gP zOY%dY3Oe%MfI4ms8&#%4r^Nr8lp)7cELJI|>i>HN^7t1>s@F;0mT?^)Kq}9iC~w&I zF9JoyY(X2M4GP;U>eWJW{m~FM*yrMhR51u&cwOnKL?4IIb##x!W_oi}_PYHc9uXI4 zr~z6e@+LS@#9Hq7UtpXub&?HX)Jc)Zd)4RS3`PF}+>7*rc0es?j|QVpYQ2he5_%I| z%bve;-U?hPrtkk2Q~U|*+0RSHJ0?gegO&?45{KjEURBo}+O_$CatNn$D zqTVGLCbYjJ2eHDH>6cKel#t#2XN%;O*B$EW#?yUH)Ns#J5I$M2$EF=A7Q~r-hubaklh%|SjrqAz_ z5k%?#HThXJo|<^D|Ddufg4_TdTfz?K0~tBqO+SyVA-hoY8RbCPkH0bA9iOK|Ga}wz zsylrqaZN;3u%~Ycg>KbuZ?`Mejp0clc)NoZ;f{kriH#{eoZ~5yr7(b}Zmd`hLkt8s zoBx=~disCBzu$46_|f$ZW6WaIxmL!n!n&qc>tfS>FB`fR#|jRIVqZL}w^U*cA<}9l zlY5xKANrWm>(p}n+jWjdS-R%SI(_m*GbuGBQ^N-^3O>W3wu)tRe<7bZFo)q3@yBd< zh4>&9RkH^5PSviPpBLlLk0d#3DrkHz{#af)^p9%K_ab^v9q5;QMbqMQPN19UVU7FP ztd-}1?brWfA_k>8O0Nz!aaOHNB>J92%L>Gsd<8Yg%4kwaIDD@YI-@k9|JK68I_C+k30h^?qds=&>r7l zXEoQw!LJHaYS-Z0y{xGn`b4Te)ZSnA82-~?$M0p0?N+fvLmWwuhi3#8ET^v&BQ7*x z{9n-1mAt_gp!MUYL6O>c;8OMD+)|OMkiYns3lI8ZSEAc$k9~En`dl?FQrQ%SV~t1s zN@#~;t@*)Nt9;AbjJu0XZ_LAZ^Lsgi%g-4Imjt5EER3Nwi9Q}E+t0xV$YC~^=?S3O zk1mInu^)Y0_M>y~RUO}9cl@3mp7<5X&TNJ-lsf7O)5T z48BdnFeD#q@%;EX_QW5SWQB`k#WO?Er%3%o=*Uw%Juc2SkXW$k$;GkhN5oS{+-U;P zx#NiPSbhE z^tAa$4}B-qpEc2gkpEw3%7u1Qx+zSL4f&#wHc8n~xj2d-pXMr4m6k}tB%b~w{BM@S z5~_%)7#$tuOf7f$f>H(Ngdu=tK3c~tQ>{}RnwlyfT?4|$RR0WTeQrB~av@~}9zPl# ziLxa?`3@Zf2WKF%9?7$r1cwP2Uydo_R@1@mhpScM3Cs++)XQE8e;_GN494rQd z?Mrdc3pMfCpry(}qW#L{V5uEA_nYAgVd8il=G}kjEK@&BWm@t*A?Gnvz2>>~ToD}f zQr=$E%})ufVqRG35EL_CeNcq?AKnsS{$w!vj5<`(mg5lZpBKi$&yHbJzyNSIZuYy_ z9i+drs=*Ys@^w*UCL~nKGg=Fdmh24zh{WQm0-1$r8D-S$PN>{VhA4)3_pljW%H=R|JH7YLGHf^Srh#Bk+*b1SXhp)teN5eaRwQG*?l!t&(%cVsPQc3RE&L|?Yp5gy{aQ8vAzg(Vw2?X^~hPl z9Vj!bBZwtlZ1Aj&gr}()7Xi$cFPwQHXp_3bjuK5g-4$z|q2Wb&hvWZ(xmIibSHqJO z5+`rc5IlWLsCMxfIyWlc!--Vi{!7LC6(4`#`?*~u9uww>Pe+!&Ooi^EJ>e_ zi_S$oyNwhl`g~-Z53H8wO=;JCGOe^Ta+H>;D)n2SQsDpbgKSkpV+C<(3A8hSDXk>E zZ9mA7fq0$kaZWjgbd#Sv8pn_#9vQQ9I);ePyI|)Oa*01Ja}qsnOAZ;;qA53crSZD= zw6amPmdzIhFR>E-8+-bJk$WR?$+VlkZE(J#zsW19q=>4y0 zLllA>iW z>qIqbZHW;Q1>X1uu+vXoikZ7aZq`J{_l@aYv9eY&02(>#ELtRr-e&$G?@~nX_V2L* zFZWWRpv*s4$UZ+W9|RCY)H4XZ#zX@R0UXA{B@E3q9OMCSh(^HpAicVVJk)UX=Q_vp z;j%x;fGFa;09~kjm^tW^0XVRj@AE~b0ADSCMFshsXvy5~reE{4azQ>=xtx)86~28% zm*dUqjNHY1FjjpW6IYPcwh~dQgH%PelB zjU5oRX5+0zwQ>ZR8jiM>a9^&c05~>zo6wv^fy@#Vr*0eW@ z@=nomMdX_~r)tOPa!%E;K-Hhw$FY&g#@L?krAQJreJCZujYJd7BQoJW_1WkE>u=JF z7t2f~wNiA}_7a)5UJ5?(yr=8vheIgyYB#&|UWMnY!?*%@`tRYNo-fAO-v8`r>b^v| zCB@a`LB>C*fwNgqcOlI==m~H7f2Bqe#}Jt1w992Dv(S!SGIt**M_dvt+sA;<5~R35 zG1Co3*+FL;%)M$6Mx?Qjh*ZQU<~Y#%xYW?|)sHCpEZ|@0(Hq=4bDCl6JjEX2SSRZM z5sR5(flIA}pxPey(^=c^fnCfzsz8(%O|Gmt}P`kpD0nL&YIP7Og+WjbANVKgSN(w?rvQTeuc|i0!rf&lMGtf>yobDVmFN zDTfpdLqD==tro2tH1((*OU#Sz!R2BS`ryif5zIQuF`-D2JG@XNEx6TB0$KNiQSSHj zf6*YJB3w3inwo7mupPq(Vl^)f@cl}TFxrDOj?2bVMGbX~VcI?9d_cPGiae(Bn3OQm zp-^d}4!2^uv=m!XDCW=S^g8KbpDoUUd-0J{BZXIn9w>>ExbSHb3KZEFR6MOb8)8${ zG)QuTHC7(gYcV`kq~?dhK2t>T#jB?idq4v_MA)CC+%=ghJSf6JHbSgsSxITlW1%Vx zFv}-vhAudOTN8dK(KjWsh>dm8as1{ZwTdyKukU-Az8w}&#iB2m&yOzwD+=9tuz@h&ZtdHXe##etuh942xA-)15X#8?+n;JOAg|!grdlXkW zK%!py+@<&gl&8*l6Sj$IhLBh|8-N>eE8}cEK8Gf-Qo2<8j@av-^;-T3eF=F@VnE|- zdiY?yz@2b;urBsRPS~qGF1}YZ0!J*yPX?krm2Vv?Q7e39h^yn_s^>j@zgFCaJf$ft zD=TheeM`8l6wfQZak?mhtD1HVxi?e=Lcg`ECjUXU;f%9p$*8E9Z3j30C?Zs^{m}J&CfRSFmvh z^2wN84Dt0Z6>$ZP1}+xIs#`zDP%Pa*Q>b~UiDOK}U*w4GFEYkE{6)r9YcmI~|PTDo>{ywPtTcqoVb{Q#{CTEMW(5xLs=m-Va>YZ%DSfe92HMoK&T#7(EuMWgFt_nTsEwy%o= zm?)h}PoZsgKkHG{IDb7thZZ1es~ASbmdeMJ>#CmD!{~!pwU`4a&aU7_`+hx#0`CV2Q02}ySKN#3VN|&n%P{&}y7$+r6n{J3exHF$&rNp|0F}{pK;6(k$#8}&a@>tinV@*Mh?gq$w@EF`wy;o=EXzO2@MCK-JO!#o zZvKw)R;Xb^UD=U9^cYIw=_rYO#j%ZVPOyomirY(%`aHMa$GWuV_IrH!k8zqEtwENS z^35j}#kSnVqb^{aEKs@gIaq?Fv8zkKBO1N2?@6scD&#ctG$`o-6f(A<%@h}z!XRfS z<45?8a(oEz6}7%eij-iD3dTywyjW@U%ktsV;t`>F8X_wF=AtnFTv>} z%6?jB$-%ZOALP@WH#W-7wt3Na!m+FJZ68}bKT`HSFf)@CE@gn`5QR*&=_!R#{IaVa z*M4HfDB+?q$%%WSI1Nb(QRu|RzPex3e$*#vRB@<#YXZvc4p{hr(CFTT+LD-HNk7SHW&k zdRTM((!uz3tQks|S0E@kwPUq%h~smjB7X{m2^4L_(1^3 zw<-#e0S{$8zu|~XXz@Ea3KKz~D_P|!DvUp;rnv~?EERYfeNI>45?%O2XB)G=@ZRNq zgIvVVW+bEBzZJcaVx^(7ElI}AzVGMBV2*Pb&S)}pFf1bIV#O}xHthrZiXqt&9Mt_)dQqMMS(*fF4yUN*=0+G*9UR zcKg(^0P6f(**LN$z&CJLc>0RzDO8se+V-wJ)n#O5z*Gg!#)n7>jC_u-Hh{>-!qFi` zISdBiE8b4&~KhEosj8puOYGwRyRgr!Apitqn!8r3te9`a*L;j@IBRgMSB7)EOp{4k;Oo_u}v)u?~UE*9V z3#8R)GC??J_fN&Zi3?@#0nC`PY1K?vQD#P`KfSucD()w68**L-=3oW-N% zP6)o-mw9f?oJ>5MZaqigIN83=Bu3T5O?4|;N(z(dc+A$Hnjb}jusL5-teO>WFC_c; z8GkgCWSR-#%BNKx@!Tp$ug0AWc}hlbO4=)O7-^E|Zj~KO@dLp0O53%tv%cGo_%`xl ztEX}Zm*bXTlM~U>h#x^@8N4H3rTb_-`YMMn$U!Igv6_S6lm~&z2DbsFpKwsaGW53# zhhO(J414C^gXN5>?&39v>e}B&Qz`CUH&8jm&!nUMnng33atPkzf= zR(N{`F(kJZz-p{u>6t9)Hmg;iR)V!D6&h0`UR zRkO5mR{2F`Wmc#o($d}4+1?mw>+JA$b+&axKIct~TM?32OWP!$jl8+MrEPs{q$e3? zrq1bveAkt3Ec1TeYt?LwbT{V6pQN+P=agAXT6)@=dmG!6nT9T+rlA>SR!w(zXScU8 zqATXL%DthQB}+;}D(lhlrM8);jar6cxuX@+T5OEV8%%iGh^)Y;M8Q*PC@Z0PL1 z-rLyT-r1yE-6EyntEsP0dwa|J#&%M5^+vqSZ5vuTdcck3X<+Nx+FPc3+uJ%?yp`n^ zL%q7}K9Y4Jx$I{<)X;I$Z~968!`5=^y3X#aZHPZrvFkc}+nc>D8=G2a#RgsP_O=ae zd>ax{k3?EFbVa<8PH&*b9}X{`=U-Oi?d>oPBgJ{2>cMT#AJJ8vJ+so=xy~z<_cph* z_jEOO_p~U=&?VdPX3U;5>pdf?=;N0lO1KW+tW%Ggc8#0o@kAz_T0R}Go}Kn`oq&f; z3Y`42^Rq)c{`e)BOsw>uSntw*ScI(fA6v$)^dELLEBz;|lm25J#Y+ESC$iFi*!-;Y zA8RdE`mdPh^dClJEB$vm&*?uNGpcgqBDl9)QKcP`c z_X&P<+Rbv$!jko6c_5s{&&gnrK&#t)^NQ<=PARnh;a5Le@!C^|Z;sZT{n*paopW_K zI5%f9wPw&f z_J)(>U4{<3{2H#FN9)$sUvj~`sfV7Q{qalQ{lROG$aA$-Z!NY0^J|vX&amcL%eoso zdb&D$TC7E#USwPHq2q$y4mfjpS655774E!_|G?rUbu*S&%LTqfv-`Tn?q;1ytqSTtt17-kJuO?ZRN5-IOI4pL zCWAA}>TFFUzQOEnO`g%`F{GZ7n?)u5EAZfh56a zU7c42m#F}%v;xbPC?J6VK?_kVtJHg*_cNdIF7EKQbVL{+kgMlS_xh&;MpQO#XkkS0 zcJyvoOTdfJ40+Sqh?t!&q|S9-BO`Iu7e_PzUVVwiA%BQ6GjcTGE%7={@(efn6U7)Bo`J(gHQ z=$pxV!ok{Oi6KJo%43Of3Hg4K4tVOp`RU3tUw4Ca?Zma2nTi@Pjn%K2YyF-gs<=A;|USEYfecdo+2D2JWAMAkVyC- z39mbmXeI3WNFwnN;oww4gz(T=iNsWd@0zm{i3-9IFX;%aPbU&P5yBOrL}C>Gi~+(o z2zQ1PiB)Hk-=&Gf5Mjj?I8OOgP%f*RekVyq6H- z=(>q`pCpv8W}icSwj>f8&*eSgHo~1>L6Ii(MaiFV$ zXeJyVOe6;7`KO6Q$){+~&k~9060+^YM_B*ML}D4C_xH4mu;L)~BHW2#YVN0bkH=>{ z;Sk{tLb+tjk;`$z63el%&~awLr2GMxUEnm?IsmO*C=mja6w^_>HIv`qo9`y%Yb=(# zu-09&z%%8#{7u#+AHVoBpPfcab^29=D@bqaHUhtkUxZ)R+wUf-&)}xoU3jZA>@L~v zTH^M`@~YjX+fMSkE4G~MchA{8X})`)z;*vA?i~ew_s)W#`%Zp?{O&FYxrYdc`HgUY zfZu4r3ilY{c)>N2YUh;6?m6V-cb8VXz18j#N~(6}`=?wv`F*mhCcA2~tAQp34|1~0 z&Li(86v_hb!bW$#H51reen&mW5|0aJR68hTyNlAYv}32k8F%05aMrj79e(%Sj#~GS z<8n99Hi3qK)&dOz^}C0;A0a&8nCBklhp)bS+_8$-t}C5HUq$SCVpkKpn%I6~&m*>< z*mWj$y~MuHMeL<%c`r11(?k_p@~*b?ZgNOfu1<>{c(1D5>&$^**Mp86Z?OJ=st9zm z^ApDsCkg$$AKvO+YbCe92^|@nB6$swM>7_*|JS^xlUIQYd4BG(#9g8o`rUJjvypG#UPw&wGhKm-u&^Mlj%T3$8=mAQ>&?I5qG zo<63X6W^Og7Qh9r&Dlv#y2`o*J{=>!Fyq+mD*>qdYI5-^xSZ_z_@t~PTr@zdP5 zOkV09n7qinWAc3W&dJUdlHj%i!0mtoHni@hi<_7^4gm-C3- zMeJJgMv_eal0YM;0$l{O4d_*-ddQ;5jq>)z$-G4ZQLV=no;JVz;37s*TEnY$W~ zC%z<&=$0`nXPup|Pd-6dEu^kc=)}Qj;S}eaCqkT>@J($Y~yWin#ggu0IIh>-H~5(tJ(kI2&+pa=1pb z^N`|isgLX&-4QvSct^_SDuJ(j!1~blUKJVmetb3La(&m~9(L8cM;Ij!Q0r0GeD@f? zaaRZMCBUyFgfU!K6Ee2DoW0yI(76^9h5)ph2(I6{xO2_}G@rcYo4gi~*E(KETFFE5 zay=taugnrtVn8>pZbB)<`2%j20_Y-CNw1WoUj)K%Oq5Z=F;|#ES|s}AS!o803BFdL z1F!hX@r2j`bcEc#K-SvVPFawRp`|VZ)MeTa z^*kYKT~Gv4x}nqcip#yjNny@K?mPJn!j^YC1MVTGbD?{{>AWLr`GF~}T00#wmiU9P zkxti2GV1YP{HDT(B|pUvpuolps_u4Is;|=P!ub1u(|wDxh4dhR{B}C8Anyg_eKT+n zLpeK~wWhAaX-{Lu-RB*ZS=IkDQG-+;_X2S3&V8r~F3XfCH{e z;f4_05QLCuD>)Rqh$oD}NTrxnm_|6WOWux1E-TYA5x#BY?Rt6pn@PNFnDBPBd27jr zkh|!IIR}p?&SH-BzU>*vb6MHjGk=Qf;geyNCV0RPt5m}(OWb$oF^=S|hd-PN^AeP* zmkZ3xZs5yFL`Nui0C<>0t4ZW~9D>T*$lC_PeT?vVm-4nl-kv3I8FrIt<*lS`ME6`oY^Gg2evfyfyxS@rt7OLfq#RGpmsCHxKAvTi5dkhk?JML{ z`tI?>cZAQC{S7bhn%kevh#&Pob@K{6(U!fc)g6I zt!XSN!UOVwLrA(pGDg>%4pSJoNDIg7Rw1N!#*buI)k+GS&=}-#4cu61Q@BrwbpU1yFTPzQSDw6aJTy1 zU6;D+a|!yM|L=*F-tj%!@jV(ia%v)R{z*J!8#5Os$AkdGkL%3re2?y)N3W`(i6N4C z@1Ucb_;pzuj%xNqT4cny15VBndBGI1hlLsFS73WO|6IGCIr&D_^C1Yu!AJ~y+{tf{ z8r@CphWHKh8{wyC>1!x>DRFB|T(K6sS6pT$$$Z}{?n?4?Zp+$yL9 z_12ONtoDJbCvn5XMY_?XI~@$YC*-@{H_~QRkEtaR(;_mcXykA!d`h))q zUFDi8x2ZoA%ckbv7QpA&u<+C%Za>`93PRU?_vV?}TLssnOlA zY$lemyz+j)v5>f^IF1EbupCC3Euh8{SFnsKMLwzCTa+c=rnG!fyR!D)8j~-osLB^J z3t=kmnzVeE8;L4ZVb?cTzKcx0Ytr%+YOBf8Hd|7sQ`==}b;w1Tf(NPZUqi(oG~bOT z-w#^f56T_yh2N&X0>5^@H5>dY9cCMfaIid)SkCY%S2Mqzz`h3Tq@)dF!kC(xgUOic zT$pP#b7ofx0_etTC@248*mEmcpGoSx*>r5PCNb)8ot=GNUOmNm7@Ze`2EU`2@i#e{ z!l2{HM&EYISTPHiDQo~)^_Wy!=F1%K5EeF+$kcoi3ma*$+CMKFRm(>`3%a zX(gE`#x*39+4yRb$*fvb-{q*j7;ngCM9p0lzBjVYw(9frYf?AOX^#~-;p&pL2~if9 zbSVk680eR>cD5|rSU!GFQAYkH;x?-Bt!!nRT`1JfuTOTDu#$tRtY*smLJTxWrSIe+-b^4w>K^j-CgOtN_SuE-n7N(%Fo_4 zOx|M7#TJ^tD@48g-MK|NZ;SMv{0(h!u6GYh!V!6U zK>kMMZ)^*lI=%%f1(}gK#WYJ^P=SCGmR|hxP4!i@P>gt9s-G z)*sVc$Wa<`r~FZmRGTolZ*j_8G>^60P4)0)rkyw>^CV>_ou4*OI^dwqqYOs&!r6$! zIgphO{q#6P-j&3@LJig)8Wc<0PO+VWnwiFUS-M%5UUzV!mP{5 zLW54e(1;j$5#og(?h{*(&9wH6HU#(4eW0C6$^v1ST$h-d%W$Y|xOtqIFt8limxb0+ z_5~yR$SIz+xfs2FVX;8Rl|_b>Z6us^&2`Y}Iycv%J;{Uo3eT~upWc{A z+=J~%=cnjh*^Je=qiA8F(82=7bLY2m5QFG$tH^5(zAV#{bTxr@l>J%B6RtW1Hx1f|uQtW8o`viNU474gi}zfIm+f>=j@of1gOaWMI->>sGH*0%Y43V|U7a>eu8-IXKgPl4pFU3b{97&DY0e6>keb%hd0Hj}ckk?%N zd)kt=d&QHfe#oqs%at8P)uK-bKE}vz)kq@o9q#1{@Ou~7QD7|ssFgL%P;z}k)mQa( zP_IS#I9l|20p~VhZy(}10Q1GLkxU~fe$h8AqGCgz=s(4 z{}l!bnX}0?!W>X8GbKJD+~~}F|MdyaKX&Q&GUZj5R|mKnsq4;9=m;!*sH;Mp;JIX4 zE0>rY<-%02t~utt*hA#9-@kc0(W#zIdG=g$6u%3(#B?iHg?TS-MRG08)1l0R7m|WFm z$73hGY9IZeKzJRh=N$&I>;qHJraIQRd7f$Bb2^54Z@0r_|34P^OutObaJE-NYE5{V z3D=qMS`%(D;nz)ghY5df!aXM3Z^A#C@GTRb{7Fk)r=gHAg`aATXX!VW>>NKgTRtAkmXGOgU1C-9o`@h9 zJIY7T%Lf05HRm(g;HO!(yv@wN*s|qpCj6sTHa>T;^W2t;neorCEJJUZ@Dh$x$W|YF z6iCGu8qKp_OQazBPQ<7aym`$yrS=K}6FKYvKNSW)_BbKYvgLE3$!E>E+@xKV+)Mrg z6W{>@x5q_0$rao5hDSAA?LFi64g>cJqPWx^Gs0a4J}`+JF4?av*8u|` zEYNUu^gHmwJZ8h&QQ$%+o7Cb1dV$IXJpp;-VDv6F^l6W$MG9VG%`tF$Tt3UdD<;6p zOg<$O@|kJk`zFNqnfQeh;x9DuODDv?T)_)1pQ*pk)L(pgv$eM)2Rs*F^s4+nVr^TL z$)~yKP>Ro1?q>3llP)I8CD9WdS>(oDD*kCF@XN0ad?H`S9%BdE+C;e&q=TGtf`?bi zPhC$C|0BW|ZcQg@zaOvv0|n75TARVMo#JKU7dcO?|1p)19V-=z_?7%Co+AR6S~nsr zH}HXf({OvOaF&9rs2P8koA|y;9bftV6QdzV{GJ@}0h7;8qi5TC@y;CacboV=IRljI zC5s%$KgvvR#{^4VFV^RfNW9Wa_~5u13Or{HdD z-fqi3;0$8@480A zmERfg+YG$$HjOZ~4-oi2N_(9rj^p1p@yFHq_4+IrqFX;uaJkF89y0O0Khfpd>%x!P z@bBt!)m}c59?X%?JHQ1$^%L;(F$hEYtMJRFT{^HnY2e@nEnwtZD zWe)gPbHM*e!5M!8x?Hsng8aXmBmS>Ud~ctQuY9_Qe{YWX>KqHH@Pw-Xx-Cl6uRxc& z&Q$OcYsCb-U1aFodP5gyC!Al(-{hm9{YV=!FNm@K9?i@GT`TAsb`m+&z(9S zwQrPo8*}7yYYw>VgB5xn{CABvMCPsEqK zvy#8>X$`mi2wqV6oRQQ6iK?!{D!%=c3a2nmDZW#m0I@8!?~~W30WWf%VcGLFJB3%p zx1Uns7fe1CM$WgGSBngMWQ(q+@=4^~Wj6e$8gBcHtTOQWJ2YJRH4(pA!Bgegcbjs+ z<>Y>mGixUB%TIH}KcL`lYv4I3K=!<(K=lpwRZ;in1OFno7F5!?RN$~o+JN! z3@q8km$P!f{W;+63huTx{aDw>_Sxw%@In^?pG)~=5Z(a15IjsZcu+6-+hXT)wvPWD z^J2S!cfF-7nXT@B?8)URP(NBOMWuP(~{YDVr?GjqS1o%>Z~?pL49 z{i?$1Zs}=iY;U2nFg4n3s>}|qNF58w{p`x}Sr^TkX|*?YH8x$% z$#3QWxQ2$>CH}gahMGkI$gQDa{-Wg#H9-Rm29{V2^TUg){o#hiwY5uYmNhK%SBGmP zVg?N~X99X6jolHeA+U0hzb-Uy0?K+MwIP^>YdK>RawGlvb)DUET3~}ZGH@MK-Q5Ba zU)S9hY4Q2y*DhWnM*%i~l}Pu74GmU1+|oi;$#gxD&aQ@@NOxPu`i%H(l^YtHS{p2m z2kmKz@G2atp4Tv=d!o>3Ag~RxZ0PM#IBo82YJkAkw_MZpS+Z$ZzoD~( zme67Je{*}|HC=QNVfVWA4TeS=n!7s@F;=s|MHv^6y}Ur*%;(`!EyvS{yIzb-9Gz&g&UY-nzbG-~Xn(fY)ulU<6| zQ!LRFY3SrY${cT#nKZR>wq%oxawlR?kr!=O-O?E8l)lXDn1+U?jg7*-jqPnWOlX*- zW*pP0*D~@!Y-xR}GR>s&%)FbMIu(s`lIC^rd`hUT>+NW2h^T&q&m!xDbY*0aI3Uo- z+Vo1N6QGD5salT+kcQ@-&W6^;j%J~WG*PEmJ`;5*X(ggrNVcWpT1sy2q>WOK?scZE zJ&4Hm6M5DqkL#4A(xfqi%H$@#&!*K$9ViW&8)SURs2Po+HNw6Km9>N-6p%d%0djIE zCxW&c#Is;0f_g*ewG%okqw$IoP84{lI7#Z!`b-weY3xDd%UGh(ytb#u&~aOH-yA1>jM*K|=potxTb zSPd;AaMH_V0c7nb=P{sn+v#3j5xSo773Vqa5b3%7v7mATyQue+k52MrKU*w8&nEw?lg! z)GkBMuIwkh{EUeznSQs)$PTBaqN+RFE^32kbCaIlUe~unuN~2Z6VnHPa|~^#U4MK1 z-wy5ajoHI8)AeMovTVr|F5M3+39V6o6CSp61#lcpTG`nKOv&1 zYa;$u0~H?}JH739V28~non3!Bo*iDzd-3V9pKbpHI~+CXrT)?syZ#1j-C*E$dfSh| z4u?!cyL>yn-Tpq4zS_jI{g&*|Yw#!OPv214&9sbL^nH8|hwe$P#g!H!G zh8^1eZg%{M?f-#EpDe}p?=YcFhjx0eePhC(5K8;)^!9qI9WJw9nD`UR|LuhIw!erS zu9#*Ln!v`J4ZWWmtpAFK1ZJ<(R;<#DI5EEcY=@7L#*>!b_LrFR0nB&GJ-9J*5W{0+eA9b zOCY(>g57#1`|fCQg0xbI}-=kbjoM`2Zx)E`prGu zrR1N9QWsXav3f1nAAaTbcl6mY;t6L%x=_xS!cTb%D=4Tyg`sJU>t6$@j%@^x^*M}WK zZ+^~>;pLzCa(_oT;rXBa#m!5c9oKgtx(vj0$v@R^`hE1$OFsMYX&=4x;^Qy9WO2)i z<5yID{P>SgJ7M{f6Hc^tPb80uo_6M(#HN4#a&S`nbyNC|OuX>ojYGeB?DNmg7T&@^ z@RUbC<&T?Zo!?%H(?Z;6EB^xMARfy><6+y6a}=$Q5P%kaV4n<_>14)4$h|!5dYN!)cfND#2H+W(gS{Oct~@~eqyyCZF9(RA>b>It?K<`V^*(R__&o>6KkESX z9)5uM&mRE(9}f^e?*MSN9sr+T6aN9){FWbb^K%QAENfnN(PBx<>4|ysK6lxY#q*Xo zU$m@w-n_)T)a-_N7cW@0;B%KOZ(gu$cEc%`E?K-__C=q)bb(8I`;=tA;euuJ zmMysG(s`FJyQGbMr1;u$YXOTvm|Mv}AG9Ma`h03;b3Q!cq|sWMDW@G?*EFSq6=PCKii zao(j%=-CAnv(QD&OD?;l$+4`9X@bu#X@VyfUnG)|F%PAAk=SS6;+D(aE~jz*en3Yn zu__lYS4HK;4qU3Bs-^V#rI#+abQDRjo97T+ z?f`!l4!dN*G7+Z9k?pbtmn~n=oZ!)P*;0Ef{l~;*fLYSS5N=v=(Y%G1Feonh(gG!3 zw&aU&$2=8x*v-4_qDvMh7A{+`AaPncb@D0mPCVg62LI^$CtSVLPN+}>0=Yq;&4rc!o`W{{MAqR zY@j)Ld~UY-4@=C7^E>>Yz-a!Yrh3b-@{3-(>0r^qkJIz(fxP}+TA^HtL{+Ts=i>)H z=;BM3ik6~)`{l!fOI*BkRtPlu+f@)hel#|b$QHyG&ig|J@kbQoA1;W`>%vN2vDnp1 zqpY3zBCQ4S;*0!mWkI|v=~7k~#K)wugtZ0nwr-07tt*HxTz{-Dh!;-z-^POYJnfXW zsUZH)d}f|K1@VU!#P=7(k1L2DD2RVoLHuAryjKvvs~}#yl>cQ5;wR)Ic@7oCzq=rQ zxFB9@pV433U!uXJ(Mb5FApSiC@udavWd-qN1@Z4Kh%YaQe_uiTuMhmfBws|Ivc{0|oJt)9?J=p};#7c!vV-P~aU3yhDL^DDVyi-l4!d z6nKXM?@-{sCk6iG9lghId#=O}$8I~TDB)*%n#YU`_-*%;Y&L{Prk{LfQDWrSI{tdc z)bOV8BBkYajqp46B!y+_$_-ffM1^Jg$@N(HZxxowC%4hUA5d7Pp4>VMzfWPAcyg;P ze7M3g?c`c5e5k@QXXKVzc#Og_<>cmDcuxainZ9z37Jf-#nRIeB7Jf!ynR0TK7Jfou znQ(ID7JfuwnaFab7T%$-OgXuPh3`{XCY;>RULua|Q&^^(+%5~>sjy5oxd99RSYesg zay=IQzQQuyn!{}g=Ip? zt+w#t3d?koYqjv93d>}YTWaAk3d>ZIn{VMgX~Hs*(VEbqM;0eF& zk3)^K)6v+EvrXN9>iv(^1n=O*kH-F3kLuy(Nes2cdS|E|GP27% zrd5D9$4~MHmVdg+`&0J%!I0nk!l(S+;UYh|#oxZSc_IL&#{f!3b}jUdsoPgx__fZe zCppn_+#J7c*5P{fgD0EE`QfZ12xMQQTeBB~;+C;T5l&u6-J|uZeC~1*V|;4Qo4T!b zQzIBo-BEik6WfUuzpmhYqbp&>*%7dx^30Flvjg-e@a`6N>ELG-{Unes z*O5;VmEHLI$jF^4<_Ej|;F}e46d`?xhs9=ke9!OmgZ7GHiuju_WSb|HVuW}0Q-4+k zyYsO9O|6s@=J_0PZ8bz?mnm~pS26oe!M7^6_(5GoRW=JAO1bz=DK*&#;*|MsN|~Jf ziKR4GT#!%6{)=LQ-PvdMjEvNU7gx-#&-~F_RfpsV0Zl~{Gd3^CQiso-9(y`1v3(d>$(56^^vN1VL@%Y7Dr*S-Lr_)|RJpPSZ^P5-PwfvW!RNV2O;e$jaUo@BRR#ef zO$}N|<|}yjru?L0K4}fr_jotnfNV|&Pp37`XcVncqi9h{cEf8Tx#Kt=YPQdJd4)v@ zn9jOt&zQuWsyRJnBpv*uVy%!66e`_B1^VfIHStC^-q*+P;;M}*O1X6^M@5<^m472; z9l|$P{ET;R%FilVNy{E(7}Zr&Dz^rUp|y?a#wa74o_TFd;*K%Yc6v1P);t1b6wbd7 zP|T2lLW2T9h1obxNDV2Dv|aWD;W$qzFvQvm;fN!77g9Z>WmgV6G9`#Ke5zx7M5E(R z2cMs7T!Bw_9*32NjjOwoV!}s+s1gY9@kir+R?*12(rT1OvrFPUt(0;2{G{Rr-n}V5 ztSBcfJN&BfK?oT#KV)tOk7N6Wkyo3NWB`#j$Zr+(>xG{xUB}ZQ^0SKd7FSoXLL)_q zJw#ZS)Pce;33yY!Td|sFHn8gGGy+!RNz~{^#g7tJ&C};nvq0=3Ecmr<2#Lkg(RV9` zh*I((}xWR^!P_(huzuQR}fS|bH&_r(WMn7_0_L>(I;shW9Nc2ttykykcgTC52c%$ zE6RLg%l$h<1AZo+)~XhMLSQxT)&snMllL)2DR0AGzxqM%#t)Px5_c-A2A@WLp<~N|C#qOMPi|KN>v*^BOD|8fg@TPq8FLIg) z`W8;};4n>zJO4B?LPO?OU%*(2YGEEfq+R(Y52nLQD=JezZv}r5!L@g^o%MfuQ#(IX z&`#?}hE8_Pe~gUWq1J)7Yu=<*2=q3i=mu+^##(+5-TYUY_OrJ(ZJIH_?(Cmma!s=_ zMEgp;D5dsAV^_UoXw&5q0rLxRMw8)}@9rL9|7*a6vl(wYyj5qi_{shek^y9bfJ8Uj z4E>Tf0g2Q|?8u8_5_-Pwp0G9W6!Aiw5I@^1#DOFryr|AzBn9Ohnn-oa`9TXgi(d~K zjeeM}SmB31F~RAFKdV?tayq)f$#}qM?#XU?490A`r!o5}kbKFz0IYnFUx8jZ*ILD> zTWZ)YN=H|$F3xQOO02K8?MZs=ms4xoo-tng@0lM!y9u=EvzSyjl3U}z*f<*dswL7C z-UI{&Pk@)wif#guVA*ZZmD;}Ue>X-;d|(%%*R|WuZJS6EN;^SnIF#_G4f2r z!a8o(m8v{$09xO^1`JZ&or(dqFF8QjW>857FWG!3jy~?@iUDZv7v1c10yJhom5AIb z7~JewGrNu8QHR57lF%efVpD+zD|-f=&l1 z`-P#H1Yi@BK&psHU~0%;B!RD-kRZWRBKczIx*rK@lp!Vo*qC#3UI1Eqlw8U_UOnT8*S$kzhYA*a46{3BKzfWf$*$3m2@8Nnon%UnGG> zv`8@Dkzo24pzD4lSXV#-#|3oO{~{OM0EQw#Gf#%SDGa@~(i$5*Z{(n@5`fpJ-TOxM zFD-HZQGFCyMmb`$1AM2}`!L0wA~L6tpXgMv!M>Y7f~$Xzj$P+NXb(CxFX6d}d& znridit+u9*qpifHi+)m}sdl9!(WyS zvpx-B3p7h3)~+`ZE8jx3dXzZ4|0VIT92~_MpXQlwAVtIqk#*_Vv92}w!5|agK8pO% z$@XpsYJZfxxv4CC^Y$Tz z>C4a1AJO08*&hZewY2wH8?0{?)uXc6sU~lh&~DMAYVw>r z+6iLeI|0usKbGF)l5}>%)$!eaz4BH;t>k=1Wgi7c;d-y0(b#7=PC*dLmKinj5^F!9 zohcx~enPt(;^rk*)$f37p^UD*Lrc)N5J6H}GuW-5XQmFD!eSyw z2EXmh6-|7zsNRnVgE4dT=oyWDlIhZjF#c(K%M)Qgv3*?u5%v???}w6kB0TRPWq+C* zCBpvV`fZ3%D5Y!flmhz}B1lea4%-NgA;QgW9^a1>e)v|w{Z}~QA#fBY+{LpFZM>{L z^ILC~*4>a~$J0g4k`y%D=_Lz^5nm)Rc@=0VDwLO2qe7gx{9wp0X|nx>+wSZ}J)^O| zeri-of2E-1xfBw8HR)ZXLpdOcIBN>Bkl13Bi|4gXc@10C>xsKovP9br*~e8~*jzCg zV5Wj*k9peqq=&DmQF$k@$Kg85rk6F(xBCBWF*+!OYv7DcR!6YTl<#OD*ayWFbeb`s*| zr-W+E8(L$G15Lko*TMM~XJ4o4e1mRul*@k2wIKT`(x&d1`pVRi?CdAi%(3V1gFL4I z^0VJ1Z5Ccx{57X{$sB zerurYmoW-l^+hDRp|B{)VpemBvaXSo_ru#I#<5!r@NX!c+>uWH-j7aB`q34W*j9MB zAiwz4kH#JJl2=;XM|r8>LWC7o@qK>v)|TI7Kv%f{V=T2 zaMKQA^n(&bWAQ0VhiCZV!7;3K*rq17Ws_KZCi_iorOM`QXlqo-qBdWTsQ4N`c&%~H z$nERNo1JtKeG#rP*l~fjd&=Kh=-Rr_1k1`6mTZv85Nk@b4JWVqh#xhMOzp|U)VPh|8lwqo-#lUIK)+~>BhkdK)`f@H zvp8IN6O1GqS}Dk_1P^Ann5OI0zM{6(?y*)6P=&(jV8m}KzLo+5qBm>lDiZ0gbj4gh z{D&H!miVkheGz$3S;95_JeUyD6*HB;rbPL9skE19VjmS@+62aIIDv#lV@LIJ_U1n@ z-W;Q_Keq4>v@v)g6>Lcdec{3B;KjOVQ8N3{FOEqxG(GQ!r_`j{o=?7XG8~sp&w#I* z-vhqs;FatTfs+ni&EEWkbgUX-Rmc?kb5UJbd~H3}vP>iT9PJi9ez?2_4F33p`py^^ z6tZ0{)|J+=*7diGjA2saZ>>xY^!q+WT}RqNZ}!-`X~shD+_B%Y=JYW@PN|B^h-yak zB>mMUx^FGkoKB@@RJ!s0UWflVli|ZYONvK3d^q+<19?h$%#vZL88UXTI*CpnVZhId zzO;90&%)IV?5u-Y>IZ#()3oatwskMUrDv3A!1g*3va{vkJfy1VtdTUkPv!JuxtKd0 zjeq!Yw(w+sg)<)&&qtGf%R`(x{dc6X%l8nE&nNX?V3F1oNSV4Yn%23!~~h=y;Y|%f%wr~PAFjSefAR8D`thvp1W&gM21)F*?D0y>14y{ zh3x6y7?Yq)pDs@ayUoa>b{$!fy@@hvt9D*KT3q2>_ZsztRwHx_?4>&E-8cYuro+38 z=fm5@pXsJu4VjUv+F>atFrAfkIQ!sZFqaz;3}|sXNYN~@KVtJ9HVP_X&dI5^5v2E_ z08T~YPHG7DHUtmVPwh!X)3&9yzmV$vL-EvYr$-Zi4MKT46qp{g&?}u-k^;Gf-Vwz| zAb=No7xdL)Wg8FCdP^Ishgt^H!E1io<9ln{p2lvqo1Ixd`nx1`@9>j*UaCbRZ-*O; z`+1#EcYh*xKRIl_7w#0T-2x33-#4K1?Lj&$WCvlU4QwX^Mu+z3Xtn|G2D$`<34{OS z2>-E&7mW=c6DPz2>lHufWq3iw>^aMfL-HdmOcV?)4Vi-DSd!p>aYi1XFFVCB4i^^b+f|J8k{CaP^GhTfFw) zX`{HUkEwP0l`qgUr&PVH;e={dM6MNzOf!L?HU!;s=~uHDaNZR6(E8vA-f4om~8) z6O0!W_u3HZDRJ_#ujK(yeVgjzx|S$V@rmek; z3kH=#O4T+}8CzT|zTcnj#%Z6DQV_ETh#`@d!&|L66Yn|}*K z?BfJfn#ucAn(v{n{B=$kcWq{yxAGR263o$)^VEqZRRcO(*C7yhtu~f$8e?d4bUHkx zl7^gO%HTRByXjW5VN_fNQ=5L%H10YmV56Bqs9B%^jrp?(ZIcq;Vv*$JXvlmV-mWo+ zYMf*OM6E$o!9!zS^5z!rrLHll>K^9PQK@7|!PZv0!>RxY$JJpd@f=G%Fxg691mmvD zouLhUH*tnlG01{xbHrP9mo>RR)>~1Y4L6DSrak~U-K?n1TIuw!yd1Onq6aZ?YKb58 zOT<-4w24|}m!C^3g>WoCfop=z+wh`abh|`pI{83t^~8Rv?QFhH0henH!`21*yP=mM;U?R`cY$$$%(QBPqY z^f7F#1ifJ^CYKvpTGA=V-1DL3`D4HG8%dH0(sLFSta+zy%l#c2-Kp^88Ws+7$m9oA zsqia8IThYyLcHl(Q4N%?Rr^v!*NSs^*v!>be2r4nFrutAMc1k&pitZ=xYSxxk~>s8 zf%}Wq1JTyWvmdxYv&MSt6Hs@JYR`9g(Hhkror<1I(!EfpHXPT=NNj&Uy$5#)AwT(y z-?YVVdNI{B5tY-%4{Ja0eGxhj8M(h9l$q}C134pL@@G1VI~JFfa{s_k{AydmoI zqgu^(hce&wr>4BPkAEm^q>5&0YO)@Tra2O5zQZ@wEkv2``dW76g+yFq)4@`1P(lvc z3Hc@P;x2XK(hpwD{_+x1@{-;6?0#!IPytK$l%Qn$K56%LsWK~`0`UAjc7dVmUlA{Ul$`nMlueWMvQcL-vNF>CE9 zLNOY(FVvoww{Q5t>u3#9qRv|6ho{Z23qN;7I$Sar(Bmr7;pL5f(~=d=kLuNjMn-Cb zt=YSOWh(r*iU9nI{1Ey0PqnX(RB!ig_y{A_+t8o9uP!Pst*h?yq91{?AAXr(y1YC( zJ(&*AQC**|Nr%S}UF8SUDoA23C~ab*EnPy!D{!a@zs$%j{dhw(?vsAg8*uC!rpBG& zH-v|zq)24816Y%8(+{GsX{#E7Hkf^qb9;Mcei+xR;^78A-V7@(9xjZKS4Y3kR1L%k(S+ApXTGN z2k3DX&BwE#5Yo~*d%t)L1wi~1pP|D#7~O~U4bB-$Q^|Wz4Jy75dzJxWpWMkk3ozDA z@XFL3x%*fS#C{Cn#0tvU5~P;IbaGF+=`}p%cBYa$&WI*H6wfEr%)GW=^Je_j=Bahb zzB&w3J-PS6n+x}i-~SRnJiXoV!-gIIZ}7v1X(#-UEqDA-Mf3lU@xyNc_TPvf=J>&r zd7elGf0l2sO~T>zgABWLSj9@bd4?Y@Wuz`*ab3ee?rN00o09dTnfI2E%PrC~BX~j$ zXOA0@sbH%)K~>?#UmM~jLZ%cubDMZJ@YI~E3I5WG#-P46MUHiG%y-S$oDSx!^@IA= zN?EHEZ^D9&4dGAXt-bn{N?7d@ZmR?tGH+5vS>l5F_7tNM`*_ADN$>M{pBumXyf2O4 z@yg81kKZTrF6TkzF9+Uwy_6BTh)684UW)n$fbX~M8uF*ylL{VB2M?x$hILt=E=@(J zT8i?e=e&Xg;wU_7OGl1>OB*Nkw&AOUS;7_xfOWL+~gK*+`%v_(M9p)!GqcdWd*-qOB*OXG8MI+Um!= z_OGJ*)n~S~JlBwU<*Mnau&q@Hw_UjjZGe6O@n~Ywc-_nBni(rUJmMdQh zGoo=i=*&_>T@a~0**9MyJG~@IXAiw!ePlTRzCMYbRu@{%RCr2hN_OwC(#wofkv8jC z7SmH%OsB&RQS0>RiWf@QCBaf&CtFBq@dW-H`5qyG!D=&>r{Ypnh0-*t!Y;^Tbgj;) zx0)xVqS<4$SYmyRy7n-ma6)lUD#QtM3r5Ao_m9EbE*b=T8nKIqA6CIBYEJf|>siT% z_RfH`!IDNv`2H_#Qn+#>P+eqbC25r4Fb_Y-!t6m!pWgKmF*LKv54*&DG|308uq03I zFcCzmj0MF;@)$Q_*h@#_D*dKjSkaB+Bx}CzMU;f0GD6c^^m5io8tmL84jx zT3Pza=t``E_e)&KKm!>{hhPn3h-g|BYssoozj_ZN<$2|)@z!iTJsO9nr_17K61-O9 z-LmzN2mLTo<$hZ(>9@T$#`{`tP5WzJ`x6XTdM6=30ua1Lm4N70Eh<@4Lav`_0qtZB z3h&er43o4}q@u6Hx1;^~N&0nWwKGUwu$7KF$#2_AxAwF=PF6!b>=tuVh45+q5Qu4L zpvfMZikio>Mnvn3)yRHWcr6`QJmC7!Oh{qN+H_R^OFtUF{1<51(X1PI(Dee2&Xo#Y z4C;Rgdq~xZ>if;SOx?yA$5~(0jx1lw=-x8YRYMs+ntt+wV-jaK);f#R*)WeXXX~oq ztgxY9)@Qh1@EL3HntIy{UZ(euj?!Oi?=UU438x|E$#iH!ts(eb_N({7FwyaU|6a|? zyR-kYO{|2+H!YNMR=@FbYTKRt64}C*{#xdl=d8DHuxIs4!K=Z5*RW^E`%yLeYUX(?|{B(Yg^g@(LjW2-DVL9C(iQBLe@-af&D_Q{zNmPB+KAS=PCcmhD zwV&({8(M>L*X9aAnUa$9Ni+-r_UUIc%DnbPEDy~5ne0zhKg_!2 zR*T5X0$oMQ!0A`VI}Sz~NZN>$>Ci;w8By^wesT!LDgg=T=!jH0aRMxqTzE1D?$UI! zA9*o=1ej>@!mr-jGDzo|ya<{rYq=D_OF|WXV8o z0~z+U$L${+(J!Y06LPWWL+a%+pNA%4;e$$D5 zbSksZhJHk`=NFmqfZm89KlzdmGy6e@jf-f~cUVqgSKgBSK39iQslZDbKsi<6hn6v= zl}Xs;6XVdQS+`aa%D249L(|`m2sr{^6Qs0^8-m#$_pa|_$rXKJ1ncOk6SM?xVgfXx zNg}j=Oi@9HHDmh=tnvm*ruL+RF4sq0RYIZnsp5s&GJt!}AN#>=tmOzzJP6c!#1m{j zFj~hT*AXaNT7CtdYFj!S`#sv04h!yui@{NOu z8`h?S0pAG(=)`IyKRf+c>G)~0L!)yvLKtzX!-MYKKGIBnA-4q8H!Tj*QED~VeZzVpds8KH8#l1w*I_+ zW1M*7O1*d!x;2_o;XG;7WiHG5ILpunkgPb=qjsf(2^Kc82p%l|a13i7HvCmUYP zUUM&iqI%T$pY9?t9Xzw27B77zdm(wY*2`Hlk=@=WE&kr@KW(OmdO@Kiue`q@3&}FJ zQ_VtxA=xHt8A(2lPJ$vRJWLZuT-&G!;QB5#9flIVesr1{ zFg`WtY@HfqX!E@dQ=UM*Rin?s&nq2tRFO~@oh@ZKL2OFK6Q?MnLzN0fk#!CO@gZ$~ zIprRxV~}F&1vSX5w8yZ&JLX5%cXDmY6SN{OJY?H* z8I$U54`TGIFk1&gj~Z;!L-we}(&M9ITS!v%QtCuO)AC}7*EE)=-Y1093QK5Cminv- zQ1g?F(5{3q47=3tEC5;+imnpsC6>EbD~z?g>Tt)ct9hvpeuY$Cq>MrLe0yXj^GFAS zTTLz)l`;P}WPa-h4|3jg*!NQXI@BvFWae6tA;0YbG(Rn1x@w5QYK1h*H0l*qh*#fW z4y8Cf8+4ajq0Qh@W^Y}kJf1zu^o!c4u7VZF%XKquT|q0n_QOz1YJ+=1)95lIEx&hD zIMYmf51ON!Pq*|?Q@{#-A~X97mb`WqBPL|GWI zX)9#!`pd15jSh26NrmTe&a+;l7GL0oA2K3Zd1dj2&~yA5IBCtgoAuuF%80z9;k#V7 zi`GEcSfT{foT4#=)>(*keLBddrwkF(!?+gMwSI)+#4OHI0|42BdTq*itcTgl%?l}w zFq+E5LtjQUaWgy586y%PqFRB(XmSbpjU1Yq?i)_eXjt9+Nrs(Zrvq)1M1#DFFrruX zRj3k|WroNO-fcvR^OQQ8wsr5KO^K^g2&dJ;x~*H>>(+*DsO(!FzF@;VQi<4(S2v^L zTCe?GA`2=ZK4Vut&n&?Vaek(sNDz&Bcxo#1u74WjXjOhNg&iA7N{3}})wSVaNSbuh zI22P`6Kx_nuq6ow#0Szvwg}L)-)53VVncNCR_WGt1QqI@Qzlv1dYMNMRA@y50AcR7 zr4n3xBIf@Sr9fJbI>w@_Z3V>)!p2)&vJ@jft}0VYSnX_K5h7xGxAYvs_~@<#+?X2g zYg=mChrIT!)RBipfieoJOuE{LOPQLIEnfRSD;Kg0FbD_9nW;TfU&-r8rQ_H>*rGLV zuU4(GV)RnWW3duL2b<8TwnjHkp}tm-Kvqmoq>?Y9A!>5&#cSz;Vr=zh{(uFv9$KUt zc=l)!(tH|xo!ah5=aR50fCYpATG&yeqvy17}FSX?I1%p9} z^R_=En-4R^SbOiqNE|oRYOcS17`xwjbNa+Dt>S{p9W>W#4)&R!*ErH}7|K-km`5 zHkiim7j>3{G(En*AYn0lT9ubMTKI?2d^KJ>_p6Rl6EwwN@kq(kSMZ&gx=nPD-O7{Q z3I`7x)3RH|j#eogtr*m1{m~);e=A$ltV1B+Fmjl!JsHdeepVThj4p1y-OfQ%N2h(X zJjXEWUI#fC<07eCjS+lnc}22uV5EPc^mpO*5y&dEj=)19$(GRt_l}Y`RsCYiZ|Gkm zuPuxng_jKryOWa;%9z=f#j&03A*1y`?o8z=q|SNF_E2Xk^h5)U#11S+@RxDsPj`eR zg~l^=n`;mF$xrPgkS$)vAH>FgjNmB!_O$HGR}(xSMXl{|)`au_EDX;ShE|iG`~~2O z+0DFw#h&Q@aw0c_Oe~!2u8y!nqe_-W)BepPWuJr0bGhFs?~dF->TL7^=t!?E;!$AU zaC2ayZbrG+?rGbSAt=j4^?g@8n|lp>8#ygp0oqL!)B_fKVW+ zC|m2T>G5Y|62y3G`f5uCymp#0OxG=WJ40~V8uZg$vf^=UBhW6X;OTN;ZY@Wt6Ge`+qJ9c0bqEZrL z52H|%5DhD)Bh4ma(^kK^+-{Ad{OBCSV4vc~?eyFBAPoOqqpi&*Vh%q%SnGYQ$KSpi zA=vwLaeX@;8o22=OuY#e@VKPK&XyNI%5Qr@T+)1~SYklp@1b}qWbJ?MPbJS8laA(L zR0VeNOeguob|Js);nYms!=L z8u;)t#V=BS-7kijba&sWxp(}pX_$uh#IF&@>O z4)-#e2J!oHtCwizp?;J;6q5eJkIpD{O3{Pfn%x!X&-xmJ^z~4dn)E zAI6_?o)b88d!hVcayP~FJeRyJkJ8(XqGq*CgU#=UmwbhbGBrHtF67}{8674h>w;S~ zIpzKpmxigY{Y-w;Vq+dtwhAB*WrXS%i=qEAMxLu%VnzLURG^Ze;YA4NtVU7-B zlP7XJbbvoD;xt3xnyjZUv4LPR-)2*Xn20$PH$FcQW_dHn0A`TL0htS;#<~N!H73}{ zy-a5zPgJ&4WyGH)+NOU#_XXu}aslCJ8L4lNWgfe>OO~PY>)unM8sW02M1+w*W3wI@ za+-KJx5dQY#J;ILssU5c+`2wWOeo&$RB|&PVC4C!i0foA99*uD>AU0JfCE^~Jm4oE zrgJ7+wyrWBwcbq-)5ZTuI&W2@&gQ0JIg zb^;c+wF-D*g;R&Xd#Tl*X9b0<^YW}UFRQ}(#H%+)5+4NWJP0vH7yuIn7jc^+FrYS#q z$KLdgy@|o2S>gYVz3JS4qo)1sO{Z*-O5kiG%&B$w?J*ZftwNTVnjm{qL_x%oh5sAd zn{EM3)SM;%hK}$T?M=tmnv(OsX>Yn-)j3<0>`jYqGa|iXZ+gexr1^P#_6O2=r@zJs z%iEh?ChEUxZ`xM&U$QrS;0GEL$Nu3pjq|6oAN&5B?M)NN@L#hxT@I}Ovc2iP{~=k# zS+rI(DqC?xlm7ktLelI_cU`OzdSH9g>lBwn(o*~XA$!x!>mhl(a`|s>Z+iNBAp4HJ z$(i%su{YUCr2G|o)3OPF(cbhyAjI~j$)6FX@7SCE|6*^N{GE5~O@Gba zH2a^iH;w$W^t}HidsF@_0=JZNUg?_W`eio5=LePT@})YRv`A-{SYkF~Y$v#s;9R|| z2(Ony$kj7uX$$2AB+viww8?tGH%HDu^6d{#!xcz(UX*@Y29+%oSxL$4c7nt=>af!( zC%1l=Fhq>qi=JU$!=0CqpT6o_M}29zpl~U)Rs9s+^!+Kego69s-2u1@rsT&% zX6;V<+n@J?;tJ})TZOA~-R^UPZUVXY*(%AHkGz~T{o4}QIOA7k zPm<4HAS(dpC$cw?lfIi>fkl_QAj)FrSu}6<7%pVf^0a#_XKA{qxuOI_TS3E|V(MmG zTv6$@>v*mFVP;oUWp=c*>d;tCc1x$U*()l_**o2u3hUW-VgIqd#>@PfZ5zDtUZxbs z&S#%g#)jcZB@NX(8=~_{+3?w%u6~$DUwz3#Ui*#OeFMzoG2W^+-sOzFW8eO&{IADV zrP#1yKgWCyJ|ze2RP{6LuX4BRT(A8NOfY^pu7VwqchSIN+m#%Y>ACnZ``$!4cs4sI zY@_3Y__n^>H&sS=8kpa5T}9~^t9j@C2PlCz>M4ynZ_pGovRDGfXMan)Uj(DGsf=%P zD-8@LUc&`Q*_FW0F4v!b7g%oon@M z`1*#KG+!KUx%aVosn~q7v3Xi|0Xd|^>FDP|41^XnG(G1Kqmvk8aFevT2ceFjd7gq?S zHWvC%*=4)pmr}3&%WSN`FOH09@Sv^5D{HIoY5tYpG$4m zbvK$+X742@r29w(e;EAxxHtrplA9Aly!WP(J@tqDCS46CYkE@E@ZT+c^@j}9xA%JOf2-aTlNWibj^;hBZnk3w z`F;3m`25IE#^($+Gj3;5U@P~X^tS9uS6@-#d+m?H=VwIe>6|DqFPeVsv z&ket6ybjj~M_$8SW;P=Py9~H<-AK_ z^Dj;AOjYku3>!FHzCeg$8ehYg{NdV?Jzo2Xu#!=(#9Q?ty;Dw7(!@mEUK*qQ_zEW` zk*@wVe)UdX+`mWUXyy`fo#}m(yx3@oH@ImcxpV3c?YqNoI~ld2 zwji?4%l^2yw=l}$5b*g6FL=MdMnyi4?~&Zlf~1UaUaEMiSQ9t8<15Pg{Xa-B+pbG$d~Q zdY-5j@s{^#jYO>@ib=7)m1hmll{_oSvci>`%&Y85#Fq1_t!gUSrApd**x=pe4h}w{ z^Nrb?ZjttJPxkM>CSx!M0QadKbyJ2pXZ>e8XN_Er#j!;3Sc0|DS$G{@xiQuBYC61d zU6MoCu`hAAVef5tHK@NCA1N;8c>*+sG)GAYhjZ2w)UGyH?qjTv5{AwYnObQ=5_RP z3ad5gb)cp^U33VyqReUagYHu039nqa(vB3cZEhaH@r~S3nNqo3316YWxpC^Mr3cv{ zeS9w`@+d!<91W;5-dO{@TEECyRu4E?vxL$)ftxN+uOU{Ze7~&WS8{z5^8_(v0Ql!5}LaAP9Dw5zu z?0f6j$bBt%JV1P021MTKhLz1nLmg3)tFaJOeGEo-g1&gC=Kjq-$H7uzv=Zz-k9IZG zh*MojLm0KHJ<+5z4kYLL(X8|SiTh;Wxf95!ynrE#U^0}+JbYR;Ss zz4Io0>=q`3uq2$St1OxZxPr%9b&z~)qA!i;rlt176+ndy1{Zp}@mhf|QCD>dS9}i3 zw>GhDk5@t|B5`i7kE7UADkBv(I(3X+{c1B(W^UbPWLxR+OTiVH!xTN?I8!`gdAfNR z^|Q~rR$KRO>%Z^Hr^9$)I6v5+p;h;pydTlyRE61V$jiB|*ijZ`+~LJ07vA;*##0Tg z+0Om5`Avs##{*YuaMMV}6l~{_%lKugUuc4jLrYCNL`f+_xXBHn8T>x`A2*v+XoZZ% zWm}6?oO>(YkgTkMY;QiS)~@vYJp;&LYjN%fFjIcEn{0p;bu1DiL=(AAsxvI!glP(lH#KHy~m_KBf8?N z#o1oVtiwUBKSG0?`+Ew5=q`KcgxDi~l>PQ+ME6cnc?qI7+Gfwc)hY zn!fD+HeT*N~MWT0mnCsaxeb%rl&QdX?pL zfWWlMRZ$9IxVcWP=2Dt053c`NsSt;$Om}P3Sujo+mcT3I+-O;TP;TYg*14Q((YCmk zXFwsYPPE7_ee#T3oBA#C_FX)H(rQrFtXC+!eYHhKt0~Scd-E+aY_-Tt6*+a6kA-eq zry4jQ;@VrLw4i$v2?vz{U(3{WMP$SnofT^kh@E@v*jwZ!U< zZ;$#$tIOMOC7Wu)qTM~#cafZdfnRC( zPv}lqu&Y&hI6s>Xo63O&n}?OwmfLIeK>2dTmKuSY%BX$N#Vm4kWM7(N3Uw78olvDB zv4X59dk=1%O93w1z?i@)E;K^~nNq`;so=?dkwan#SH8!UcW6W!EOA1A0e&v)x_r#Z`Krn#D5)xVTqnvnkVf(B z#E3|i|E68|kvozWMe~(6=*SMEKn2^K8#PKKhv6)y-xU3@65n*r8)qN<%E*YEddF~m zF1%nJGj&Hp@F%9gVenY!ozN{_l4B0R{E0*H028t6j4hZ7qS=R!1RXjez|BL4Q-8l| zLrdp%zId_s8JTd9k=zT?(PN3{fuO$I^_ubspz;JA8%g9~Z3oOJ7T81(V_*sy%=IL5 zg$qS+pC%aj6eD)M@-RUg%XJJB*?{KH$vR7Z1)ppG)!&o7%%!BXCcyeBFKS9preTzh zCCM)1HREaO9Mh2eg>FSL5*RyjSD1O$gW{t?kz-})DG$TiIFS^SC&HQ=rf|W zHHDg1Qiwh%QG0cgsZ*G-KzoSOjD&1Fdj1})#RIAB&(O}f6aYM+6O;jm6kgyE4l{Ab zFu0&;sc%VNXN~9*sjTW26Tm#T5W z>i}D1Z?2`?LqO&{vzB_Y@4+-Htdj1becc9R8rD5b4658F($Qe8TjbcT>wZCaDbY1v z2j;=) zDZj`hwgf=LPIj@jewDhZeq`cz==F#cc04!Z6T_7vE?;sd-H_4=#>{*H$EMFev8;R;?Fb^XeCU{LWbDJf&-TC$)#RPE znNA;6(;*UB%B)GyCsQs=x4%GFtT5nRWs1PEDmyD)xrQEhV8V7FV(djfmMRmcZB0gX z`vxu3s0W0xK5=$;TC_>AsL?1n8a%)pa=5Q{O?3|Q9FlUBTdUYt2T?z(l+70EnMNYh z!LEkjxrX3nJ4w5licCU=9hzAif>()lCr*OQ4+TnhByxvpM?YYKuI~ydWRg zi4SowMW-LO`qdA!)lyTk(`!GwQU#rmkIrMX@8Oi*EFu|HWq@}l^&VS|Ep=vmOm8M< zNqX3A8EAP1u9IZP>t4t;ACpI+C^H!pnEE(p5N3pqY#2jfW}V2q)s7^I|FmrBvopDw zwNw^b#E%rwW-~|Ps%g9pQ$7hf*D~>YnTAgY3qNO0z~^Tbw-yLUOVMZ;{%t z2>7e6XY`U^Kxn9X7Uw;*rn#WP>U%8@5S{)kdTlzmZN3mpKE|Q_mE=UCmugfcUuWzL zlGLCLy3T~+!p<6U(5^0Dprg9YOdXv=dJj7n2_NK%g=|Lmxn;%nNV*4rvl>rTH3#ZA zU|oWaIcPv7nr2?B)wR7&`!Pe{HU7PbOYuo8a8JbO=B+xI!W_Ar40*ETg9{GvG844o zjFy*iEz_@^%(7F$h>AmqE;%zwAHu%HL>uJkYOW3_p5U#?Y*IZlx_9x=o<-fEk;Swb zqFkb68S2_C)@y&B-T}}A&QCp{?CBYHj)hnD?zVgF_pA5ZdGq?I+t|0GiIsqk?eYsx zfhkHjQBnF4FW$ksSD!0*SBj%Gx)}?*m^&CVqpOr+&3}_l?n)=0I3sF4R=SkC9}CN6 zMjc~Z#d|q9@e@8xSITI@<_hC!*c4yPPMTyc0U7I}FynfsOT3USx=k83tX$$J-Gv23 zozgFWS;Oq;^3Jd>^xBW7RgSB2CtK%tWhELhJ~&~>SzwcgY=hmKZM@dhzsyq%jdbvO zc2}$F>6Uh#z=R-sT9{GDZcjO+H+g z9ICC};zfI<9f$8m0qJ&2Lxa!Ld>l7PwG&`)++u`oYDsC3rM8MIlALSqR;v?NeFgCqgA=8;X2h1jptsx&715Emlf`HfP1_rNX$%_C zy=BS}bctc@#?@&P+`29m&Fm#!LWP^gCJa%b^7u{fR@+yI>54j9c`%l+wH2G3Xo%{@ zYQ;Ae%k&mErUigK%Mvy!AN{0pg(%7axd#bxcieU+29CZ?bcZcM>k0VlB z7}A7$7}Afo{En`%j;M~*zm-#T0W9}@Hvy-kO5AL&~Wb-&Ernl^dD=l{NXsq6{|Kws9!I>_v-m+~j zwsAC8Z`sQf8@iiIxQlFT_5wxhZ`<8U7qE@ilRHtOAl6&2`Y3P0b>D<_?iBUq=!69- z+{tKj)qAc`Eg5mXKC^=2T>}G9jBdM=uZJBq#kk!7h^F*hv{#nJ5Q=gTb@M0k0BT z9WojDkzM^LMb`b0*D#K#U()emsw@SinabZ-`) z5U?U_E;xHW<@P^FX(o8Ch2tRQKTt|nc2XC5gqp#nU>f3d8?BX6((p0k2{8&-t+hwA z$R1rLI)gzrg6-@g9zQlA>bPvsIiLoh&4_9;Ky>XAiecAkm1Ub$kEpm?oarZpQ!(P* z)=w0+K0?N+2!uAu=TEe&nn3|)%`Fif%`N41y?ZU^HKEtAbE)O&&I$$TQj1ei9~G- zWGaaZGct?tu4*IGp-Guf^VvhSFUxSrsMLO^b3*gX-yCalYz28xqwNEQ%wH<69{DpA zOGWdLi7Q0Uwbq=-t&U9GlUP9C!L2cNg$MuvAoAhT6nk<&w00Ui%tGjVau11{_WN8e(i8M7|8@-F-=%4Jw$V zwTbu$-#43KCWq#U>}H%`TZVjWr+5l)9PLeUi7J=QnEWs5s?w+{iZl(UXLO1RUglhe zAiOE0VM8$w&2vQD!vbKg;$`#Mn@zuwOoW|Umhkz(mFHDUT`1*mDm((F*ku50>w%^1 zN>ve#NrktViraML*O_}dO@0-1_9$zc*_7#p3G`|zJa<%$O@|!b{`(5sKz`IzSUyC; z@?~O`E}V#_Ssa_;Co;L62!lqNr~GOxB{q{wA@yh2EBAVCsXK&A7P{xtU1Kg+{B-3)!~vaK2K41S%BVx>z#-Ugwe9atrB^0S z)%FJ4ySfzcM4cMer`~qO9StW9X{1zlt%g6EkA=!BcuBFK;D7Wf(2yv3l^(l*8y}ZlBVDGB%Ki_mrFE{4wCStw zLwEP%|H`RPY-*zgR9>)ABA_TSSs-=b|+z7U(Wj!>bLH`o43e!pXsu zc5QVZp-%K`fs}=%jG$Yz$cV;X)uR65F6dXZmcez%&PyQcIz`Wz_hI&nKTIj#V5xZ{zku&yLzDHI&r!o8bIk=Z} ziN|zdRvp*-)n~AUJuDN1Tezf}9%NegbfcVI2=(u%X>=y}braNjg@XI=n%Vvg9u~#> z`fu97bcw2^H?Amijy43x(XJ?=NJw4kM_iUrS)%7ZKN^HeqI7pF8h2Y7(Cdj>v z$w&-VLZGd?kq6V`I));lEFo6k@9{GK%07MmUK6Z5?p_mg)l_t*WE(!F+mLXzCH-D| zrwGhqo?*wb?M6bhcrGDXWqNG>dYAsrXkWQU0wHGr!lA=6yO za{B>9`ceYW9_PdOZWAp(vdS3Q{7+g(f;>UX4{^j>OW%lN@rgRZ_QFZ-E~Dw`;Ih@; zl=!sgl1SR4098>^ete_Lm0_!HLPsehiEj^gl#?;O6h`@5Rg*jd&CpF9B`$xr)(PaB zOEKk3Pz(VVFP_vO@=6s#f?m0j6s?hHf%tiJy<+#IZ>`r(Zi2OpR!A|6Ku8C0m^dVz z*o3YXD`+A22|uuVf?$9i zU#lvpvo5=82_nA!hYSU!AixFRS(2$*g{1I4^6UY|T88iz-- zzC%NXT>>=9z+ar~hadMcT*?F!&oqzeQFCN;I3A_+~;DZ z+jR9#fl60f1r**~U-F38j^~`FPgU9w^kcbn+P>;gp8**^HM3uq>hHt}(yyiXNojiz z#!PJDo6UY{c;m)J5h@W*GL755qpj+=Vo3%Nw}8~Om)z-eoFj8I_S(zF;66F+^_bP9 z00b}EC#c{u&slo*Y)J55O$dIdfj7WmiToy?jWwQEfbZu=c*Y8nHZM9=2oD7{ImW6 zbq4Vvu?5LXP&(-5971 zPSJHq>c)8CwQxCfR=iU88=1}VO4Zm(v6^0c%4kpQVG_(No*4}VO73GUCE}O zScGvcJ7&7+G2Cd69)d}<)H|9_a*{*#22E-B!lv-JjxU0{>sYCu=O9$HQFR-khG1~& zj@0%nTf25``?LvC9}Z`&jONejWOm%iqHEMr?4s7{F3ILRVuVy?)V{XVQf zTsg|N6D`68w$gE2jPwzVA-~B9?6wz@+Ocjg{#!M~SxABxoo{Ro%c$ z!a;U29-5sp`T#q&ik)}-VzNpO)59{m6%X>qOnly|j~`)Z4yvEqY>PhW+*hJ;WnN~1 z^+rYo0e%0o<7Hw%>+){cJIQ=kinn8R>s_8j?H!=fRCsFXRuhq$6tzIe{E3X3Vg&=# z){@JvPoJt!T-=(VLAu_a&NkJPDe*^qU5D9Mr1gUf*M+uo>P@L{6_hd~z=T`NC1Q@S zZRg;^jijztY89!(4(qXRa&L99B`#JoqVi^ePu_meLebF7t61?nu{|zU)23qkUF-lX zM_%a~iq()NZ`Q#bgfSGWxls^Ytds(XGFd4a1+hWX8B$4@yU@F|512iqVbxT&xs+tg zNOed>*Y!Y0LX)YJkY;I0=oZCB7h@Ya?j!?aN*VyrOgljD$!0z$qFWfz=Tn4|s(>r_ z#mRij!^^xIlRcxhAvEx)`!Xvu$=>G1tT%CiU_G6i&uo>A0O@G)`^x``&4Y9v$vud@xqHyxhE|{H8%hLYde`m!lV%Hvk)= ztHbxz1@FT}j@}D88%1cG*xRq9UNixp52@fV||FGGH25R*w$W_lU=0I~LElyl@4D^}Ir~{ySe(EdPyPFiU-mT--1h)H#XE~uw zW8w{Kt>s@8??D~eJyB8@0S+K*)u^Cjli1WP;%yh#7Vyk@Y7+e*?vhCqrNbvD&P700 zWICGmGH}tjiYr-Uf9&m+@b4=fUBasxXjejv^blFpFuBf4yJ1?l^uGxX{CkNQpQTX*+B zKU)2l8fJt>Rs;%D}t)G;xaAb!DEl&!Z!L zB%Uz8v1VmqXNoP(91@J`@P$G5?+op3V;zmX{JNIGX({IFMv+~FN+`nXK>k%9435{o z?mJ!ZprN|ePD)X;mFi4pFMUX`S|*!)HWNlnUSkb zj15LqUk)m0yEWj(S7cko{B=7z>K70jjsFmd zX2_@{%vAhw3x7U|*+SKDfN1)$MAe?xn0^1rx*X%^yb&Mn;3)3CZz>foArUZ*REOdC zTJgbElMqOaP9Vu*hCn)Dp7^-Cgjv@m`!0Dk5{G1uWGM-pZp_;drk?{IFuaXTrd#D? z>ATU%7|aP%>erEM`h_OdQjL^oR?F9A4`9UZDM?H|WYdudsL9t3;am9=M`} zLSz~yLYY=Tf;XuZaGYjlGD*82Q_EU%rkWFDmJGgB_Nz7`m zenvoStcUeDR(A?HBBZY5trIqQh;vnR8fxK%tz;Gln%Sb(L}z~1#|=iRiext*KlYo3 zMi&?+jpS_UQ~{3kt(HRiwfAH8=&Ypbw%75;cpPwuwDyaR5!h3ih@HEDGnSW=E#%u? zBXXeQLVIy2*G;?7A`%H5;X;irbP0L|lv+woI;~%P8BN^iHh81rZzP9;lZ!D@kd`1z za58J+t{!q-J%>^QR?3}!VIl$|Ozd2ZqSz(V+t7;~+@*}sM2svMf$^iI9BlHZu%Bh$ zaRw^4QL{GN4bqilV0PC=qd0~baTHRZ%v)t=8e#*Cm)Uic;Vvwg@5`tjQy?>96|^U>zg>{(Rj1jR^~dKAew^8yLHNyq9Dc50}N*uf}S)Txo-AlxGJ zOw8*Ak$8@VFlnnMrcki}6YE@tSN1FKVPn5bnh)B~H1lx>^2kxz~- zF^5GP<#&%MBJr(LCRZv&M+Kh-x6y;L8uW!TrTf?;bQakP=S_x#8@mIp#1IVuKY`Nn z#yDc@|K#m|;Nz^SJbpZrOd-YACzS#PQL7G`3P_4YGq%M92AF{f1gH|$3SHx}6>;sl ziFS9}T1WyNr&H=$uqsGZTv->Ex)!W1tVv6oP?k2O&;}3)|K}lsDF_Y!%J=;__db(J zTm1L?eZP4@=XvgP|D1d7x#ymH&bjBBe$!ITL}Z<1wp;()ntJSK)&JQ?3y8wRar{^~ zI@VN^>g@3B>D8CU&VS1g&9S))$X>jtvVs)hg-{>GoiST{BnApK_y($_vbB|yfmU7d zXqp4}%4zrCT&N0eo2tGg?aWnh^~Zsi{;pM8;WOyJZ(GQt=1Ya(#@lQfwy`d2yD(uG zopx|Syyt7x>E3t`{g?2lt!#Ud@pBd5sk(yB+s(jd1vA={{JtCY0aQ#C@&ZvYw(m%y z69R4AF9{A~E8BwIuv^z3IDm57ZR@VHf?L`?ObZ4^RhI*?1%=8!jeZ{iH-a|DUZ=Jn zZ=dbImkSl<++kXSGhv64sw%i>OE4)toKC*l{_Fu86n80WkP1*8>Fn)AeJnuLlo1E` zU!yks@*QCefNR4`nfx_|+%C!8W&+&*+oaarq7j|_a}E?jYTx7M&mpzNOx-e4`w~R% z3FuFd+RtgOjMV<^0?FBH;a2R8JKvZXog_Ylbd1!J@Ct{$d4c94GrzuA`7S*^240O? z^}7H}7SAL<(_QXS7@=ywsvWg%HR!ZNH~?~ zOyK#0MRWUV=2N-&<&30F>(&`RN77u%G(+>=ja)sPw#)j=Ne-=h6*}^dDUO%t{hIs$ z;?1>gQ4mLA7O{K38XF^8M5lb?7FLPknZnUCu#|}zXSks#+ThKdF^n?W+%7Pn)e*I) zj_oT(4m^LkdXhH0qXm+xXfDIut6bDD>TmJFaZ=Wr{~uvdsz(c(^-YBvt9Nq|5!t4{ zf+APD<@kyE_qaOgZc(srVw3kVi^o3G4*9g>0cy^{unM)=_I~iVjE8jWp-k-IbnHO} zg18*AuDh5&{|6q04;^IS2ig7T&p>sB8FxALdhz*UOrvB;Z z9r)_`BzdKt6 zH}C~7k69!ZpCm*0%vJ<&^D~Md4OVP_$eJIa2#wm-FX-ACSUu|j(?biNTdlXkj48!k zpQf(ws+?bqqk{#wsIG_pD@O0L(FmCv33%K*;#l>r_Aq=9#P)piYRGU@SP3gxvayyjjC}r z>O}Q5^PN;!n4=lv_3ic}Cna~o2U>0U%paKX)sq6(U*>+I{RHmvu$uK$GxTof^#CW#nPDsGIN0)^$ShZwJ+uaDKK)!uJG&Pf z({7DdVfJ>upuOuwYVLy?^6@KN2=-$2d5B809n@ zIC}%7X*VLxMad#RNLGaG$7wT@Kf7hA9ZzFUC3(ZF$?1z2S98LK&8*o}_`4}MAH8oF zPcKY>>L4-Bnv%LP+kCfWb;Kq)o(y-V#y^ZnQ+dQzo09jNNpk#ysm^at0N z8x}u77ryfYXzInYNo+L|&gB1BG?nEVPes~u^pxg&BdF_`byclr|3T*u1UbQ0RQ^Zj z!1NlZ8R|A#&wE-o0uTSGNcH&Vf;;>cAM&;rE_=eUaRlb+XL)LuSl!$>CL@2dt(l3! z;a!xA6mQO($C>9D(QX=*b}rKzUy6pPC>V0AjfYTex5f%1J*crYJsaDBCSdkSj2$Cd zO;#E@g2BfhTiPk|O@JTE@OKXKV+7X0JoZx+m_-hrGj1H^si!bP1&u!T3F@+`Y&5Vq z_#<#r|5<$LGngZ5W-ljZPH?!L%;@c!MK$lBDwSm8VI~(y#}*z5fMZ&EGj@ z6?M@c@^&JR#q0OPgBp|!8YR)mWlbW?Tb9uS)(lZ(bfQk3;si8>=flbv2-80x7aLhlGJ`Ft zVxP1)pdYE8y}rt6LdE{y-}Pdf9DDuLHO1*sZ$FFCNl z<>#;p?sLXYvmR^50ngasjfy>*@Rl>XluZnth=9lmB1K8b8&B(eFz9Tg*0NJ|8#s?w z%3h5m@qWJ3i8=r?zJH%i&~Z^8e18I*-bKQcABvr$YeGVj)}lsz_U@-g!B{ad5o_-R z@a>P$iJ;BzjxY2wg_D4x8H!}9oV%nQqI3Jqv4`k1 zcwFVCAw&M46RZiD{O#HdIdNJP5`IQArgTh$y_(58kxzv`tpU{73EfGJEb*~`+|FF2 zliN6{A$~%SZTQO%Y^bj=!O;t^e3@PNMZ{g1n~>y+6Ec*KPSk1_czO!}23@n!8ZvVm zBp2lGtk(~RXr+88Okn$Fe9|4K<#sU!7a6c{4!6HC#IL^Bi-EnIMWJpj0eD9JiZ^aJ z77d}8(=^T~Oy1yx4^OUJbgHT98d0>0nP-*Xx3)hVPQ0`EmRwVHR{G5XPB z%jpL|&XWXB138doMe)O6FZ>8#90f#e*37_r;dYCc@ z$;xea&em$2me}zt#OYR69P?wT7UfiAaRQ|`l24wE{AI50|E=Nqq*Z5_DbnneD7iL= zXFsBvyBa7l##5k!jOHmYS^Knf)t#!-90r_7P{U~_=P&RW{y@R z8c19F8$n@6Q+Q%TSbS>e4C1Qn(dtn0H5SS`a08(T1w&Zl)mx9jYX*!+|IHDpbVeqr z{?kL@a+Se_P@K_o8B{MLcse0OYVu29S1X>dQah2DsX2MgN}6eZB>d&QbfGZeejFt3 ziU?9WZkS=owafe$+Mfx(ZRm7|=&S4`-}L)1x>R*ZF33%|*4JDQe%qf7*KYx)!h{Xt zETc7x2_czb39xlqt$0>zI-2%}!uPYaN9uhq`q=9S05a3_WEHz~a7KSpheKrC3s^&2 zMAUroo=^RtCpfNXPUSp7@NaFo%~+?*_0fex{{YWjKT4#F}(3^Ft;Q?F5{UN%$WkY+e8U zD(#?3T((;x&U)qJ?;GjwruXcndtKd%Grp%k_yO24vySZR(`5(vjpcmnt@k-Y2ODVd z5P8J4Z-biVde3W(>OC71{A}_RAoys5pUGvR&2qyi6JYXT9*qJNc@tKV)7Ky zuwSZD;bU;>7<^!#qEOx{34^D_VMT4eR#zp*l&PM8J>~U2-e~nMi0ZAtIj#)Pu3oU% z2d?zzoA|*~6!RYTd3PEtx6|)phRT4ph<^@{-UX*7qkg zn}7R3#<0*f1-IXQ^`VVYX*TlRsWh3cpOETia-`ARpcQyumF5_6ZH!8jO?sJ1(*+#f zU!|F8bSh1dEV0XLHV@@0ROZ)7?=X8luA9-mftf0$ld`5;dBXQfDowwg32%Ri^ujEK z-*Km9#dOTW6gqZ_f=%AUQW#{Q+8+xyAv>_tb&D|ky0}jT2g4;QWn-yw-l%?E1RET~ zaXWKY*^Y3bD#KDiW%|>d(3&QGGOPx2%@$6_VDX)g#TOF)jZN<0w2|V;pQ5m6{%pRK z(I%S*(Nu4j46@1{CY}(R1y3)MxPaL`D3PuOdg(jtrY`K-8T5x8Obi~q}= z%9Ye3?jO#QcCj$KafMd#G5X(P;p77>C{xJDf-;-(#koKnUi>SopyB`(WDiuqu7Xu? zt}1x9DtNCdKtG@nU}we;_Fbs~={4K_G?Fg5Q2cDoLyMe3M<&L#xHHUzD_STltV9WU z&w6!>F|SO=wuqT~d2ytDC_~>lR;o>RHntNhK%LNXPuK)1>HaAIRlI(-`YUQ%FN7l= zky|P|kPh9A`jKqZc9O*eaK&|LP+mhWb@ra+CQN|;UJX`7@#BVt(H%s+&O{rvJMF1- zJNueZ@{_L=jhtH)9M`V|1vGN}8z*a!+=eHH#4yPWH}HdH!V!x)KUt1w=B{7k5|#-! zt=BZ~6(%hCNn>hg6AbYX zmb29dD_*64`!TY!-ldbU6HKMZ4%5sqSS=|6MV<6iz*?$yk%C~l#uM)P!k z#{}EA<3MTsAS?!Sm6i3=P^3YSJ^q#>MW5{Bm?Cz3=>cUm~w_3J@_tO+dRbs{vc=Bct%u^FU73}#6mLjVtSG0Z8z$9_rza+!-Q z;US;`JIOxwfUI{=Nta~3@C(V0z9On~PY+fh-S_?iP^MWS$vJ3HKVu67QGp#|2 zQ>ExMm(*oiG1YkwTQA7sV4HG7R=nxs(pq?l#|h8QN+s7xX0zE4(uI=_W!^`K&v6gM z?4aJ(q09PMswO`1iRcQld19%~W!SsfUJ$w2UO=1Owp5s6viJzPuhG+>j$g}6viNAD zdMQV|;MMr+7(%|(`t)SIrci5qZN!L2J%^agmvF+^{58gS+TLdB=e$LRk^BS@5^Z_x zj~>fCZCy<4xAn9=>=TS$VcZKJ7boly!Xp=3N4)j-$EhKcbYWb0lE`CU58Ee`q!uRL#Ygk7-O4+p zbHBZh@vz-U(p$FqYA)V(cx6RX{^T+*TaN0DN=JX0mu=t2pq97yvi%QzE;-nmORStj zwF~s_sm{SxGu9#zt-c&xnRC5mb{K2n*K9GY6wX~1H(XUx!x$dG?^fQjf86QT`Oc0# z%fo_L3sa%#YCxf>$fI^XsRlBw@m2n|*odb1)MhfP415&(jQ4#jIoNs|kYg#ZV$Dt( z>f=XZ7X^zdKgrzL{Yf2@=>BR?TX>7Kwtw2imUYw_rrenyXMK`yZSmhVWH42LG>6(d zm(g<)8t8K5Q0q*6#1$b8VR#L_;4+V;JWiz;o1m^L4%snHN_zMDbZa12+I=Nugjb2m zork@wxoAe#R&TpgN;y#zT*g2b4z z_dxP(ffYB}sOwrbaVjhn@pB4`;@E|q#o2MoXdjOlT+If?c_JajYR}F&4-u^dT0*|S zM%3nho=Cl%gyWkQD)U5&3MZZH8+jtFA=^HlNHd~+`{pt!*SR7+1fnG6W|P;b(YB-h zs1K51t0d&Eo<2s%{o-Bw2)Va4P@}xWT91%)yOX`Svz+Am546!q+@ZogE0+2l(&*u0E=(EF`1`dXnNJVyjR zG-dp9EmNRWGpC8r!kDB*pYp}XpE$ap&VJwL_#WE^({vNsMZ{Kv$10Z;zIX`nI066A zN0ojS!5FUZqgsi|RXq1oF&l=SQ+ngyg-9x<-yNBuv+n8~vHHIUp)Bw+Lq{Cn+n&Ln zg$~oNcnixj(j0tZjHOxD<(^S9HJRQKHCe&=)=(T}=bX$)@Y z4L<~F*@`RGk!F&!?)pndM6YA4yA2X%y=|nB>cx-WWbG#1>{D*X6*{O4P&J9X{dSPT z(ZcBWhmi@rEKI74A=Ek=CN*L?C~s#-AApKU3T1rHV5T)-01xFpJUG*2|DkT==5`)%_(^q-k0~j?=x(ER4_v%rzg!$jf$Z0Buj7>dvQs%%}cHkXi!RZ(OHe7q3Fn`-prU+}tRJw>_>SLtT*dsyR zA_Mw%(^zrYA4c@=9MFiqSjrn`L?0il_=>4=?p#Yf(hO5NstbrvR^cj%r{odTpGF*% z!(+N@vy+&+3d8f0t4{sOXrH=09xtbQ$*I}Xf^>C|l zj2g+qmWO!fioOzVF~R-cpBkErcTlLx{I`@nI}PW8$^FsLpl8DAfk7>^B99r{hr{=( zg2L>+ucHC_Aj{i+7WMz)3z}w_5B_ds2;Umi;xk4^9d0D;|0gisjl@t^L3-Mr{rZ75 ztK1rH{YcMr7Q%$spVkik|rqY?r$_aj+Kf|alj@EpEYACIosBJ zJ3xjUH4jdZ$~~Bo^4y;rbINQ;*g8^39bCz?nL7%zdNWvfyh|%GhlD9;xtp5Na_R7w zKgFH%E_|tjw51mqNLMCi?mWg;i%07@sWtwF*| z8)J88;GBP@ff}9Yn#rIUyzWF7aBATE`~yIny>`CqD?mWy24Cr{v`p#rcs-Cb{z^I& zip-$`ep*yd>8Q(k^}bA#QabK3pbu4czX7_Hg6UR9H7JVN8R?~r(Q}w!iZEEFS=s-n z^8Lqu z4G2Ch_aItLO(Qs#=6SZz5YfCh+?c%Y{l6n~<^-9^+@zXO;?S%&k{=>hjQHj(C&iwn zdN&=c`bOqM`wiinG`OCDW1`#KgnOB*3_g}{s2RQD4Oc$}IN=U~#)gY$Gm*L5ZhSFV zST9apC}TA7Xr02J$20Rq!Y_s4_bHPvbhFCogwrQ!&Mc$F+7B?uIgY$MTP)~N_BjkG zxcfRnW=;|Xgc(pz1yW_N5}>8fAGf=6CpU-(!gLh5M>ixEQYRBNV^1deW~Q*%2iU}Y z;oH59)dbVb(z>paB#I_#>67)A+hr%;bVH03`Ik+^?mp=_)cFdG@v8VG+fk0!apz3O z-LZ}*Vr>D7K@Arg!(p}TY78V*!!OcwA6fvEittO4HVU&h;JaHI|NW>l{{90H`qdPn z7NgD`WC(YDUlM}5C)(~xD*kRNl@rBwsYs~m`fB}@0)3myF_`5pMaQMrYt-`B)WKQ7 zHfj>V3G<8<*MWHWfxSl=p5fH$cjLwH>XUOs-`4}(#P0A^u??LG=B$b|CC;sn(Cr{4 zRS5!J{H^Cg<6MQ=>%a2HF!9>^4uFX+ibR;WTU|b|*UatTi|`{|{HGBd%3WBXy4(XA z=`!6R zWU78D_KmIdsG2&pbzX=B1-VNwgT&;0TqqqgPmIRLdCL6L~sKKov) zJ8~Kd&tGkH!K6W$p5=Hgn?9=jQg%PUGy!u6f{e@iUC8C{Z!+CVv-) zc>9_=#Ai=O*}_j4>voaSaj~EX1zvJz()@umkX(YooB(l0&h&{}3_=j~6k$2#ekC8Q zdCBpk%*J1Xb0bz-=85Mt4ZzDbDArrt_->j*s3gH1H`F{BJvDfZ6*K=k7*rY}u~UOn zs*B%r1?3Z4(Z(jtdB<`?N!y3KLoC!|RD_JZP}3V%QtF0~*rMPN3k{t9C1&&wsc63) z$Z>pOsAXC%E;t$%`%l+eZ_9fbp8kNw!Uwm%ZM8$(FAQ;G@TSpWmnk%{9Uj=Mny}97 zhqp(Ud?3PG`)3Y>tZR=NMOLt4rpUXr+}Sb9_7w1#TsRh4pQB*-4&{&hCEp&vq3g*c z?E}+uOfE-+(eU5N{4A|oP7DekU`g9Itwl)sOShOyL)$E|K^ol>g}acHXlQKW=V@}k z#Ha4Jp1SR}xHFiC8q5h*(@C3b(ZCKdmuUaLD_pzb&q7d`)kyz2IGRgFw=Oqc(D<25 zZg1nK8|Qrb{Pg9&D?(Uyy?Y*&Uj8d}+5F#gTq~8RBe6P@+mp_q0EqSxK zFC?a>^3|!_y{X*tM8D{A^%T~ejm5t`lAjG<>i$9@{e@&0oO3VVZ{&M&Q?TM>gr7{| z90mpU5Q2i^|K}(K_gpryFx?Y=N-mfrp7dWnvDU73Omnp&*tsmhfwoC)3ACV#67^qt z{R^=jUwZfp>DFDjI}-O(f9|@(dVcVpxL+~HR*UzLb_Z!VC_c@Pz7baCy2MR9r*o?k z1N?HXBc1C^bSsIg+IZ~KV_tn{vD3wW!8zP-*_l{IdI~#@4mxEMEq0@OHZd=aD6BAq zy4vbN;(<%*%H*EUO)k>)gatD(Cvc z&csU9M-J7OuDZ@fv#F3c*zSFJ!Qb`v4^HC!_z@6RZWHoFCLd3*e>!H0MvJ?k>x&<` z4?}hC_Y6rYF{QYOoQxcg9jQbd=1hyAkSGwfNamkQY3weZlhFEM&y#qb39LcqS7C+Z ztnKP<=PDmYw%C0*t#&L*)S>3zl;K+qu`vjHD}Xsm&kr2{RoTMlhwgIuYr8 zdph|h<}3o!4w(Er{x#LtkdE!*gHl}N`i-gak2Q9_7IcbQ)J`*}N^a&kOH=c7R{{N% zgO;u*m{8}hC+Gq2lgPdqch!;h!ECZE(Gqk%4bwrMm}wqa&q>pyp!AbcFIR+H_%u3R z8rG$1FW;6}D4)VRjGWR{tK5JnuByKe-V|0_++`{yx6aLrpAHvNW2EmE0_LYrq9Hw0uRVm6~n}tx&vJf@VX0olP@3tVvpE`~q$_=WK}G z;ig7xott^n)*019pT;V-Ecuw4h`q`LuwjzVV|cSImo>Am!s;*H;eIDAGRAOOqPlnq z8&%3R7$rh$7n^uSO1-5(gP(H(+vRr^0p_!xYn+y2`m)Y~%Z2r=QZ2qgw;{5XrwnMVVel^`RjX1nFC*~Vu%M&g3jY1R&LV<9!bXfK|EZp>TAuml`PjMYRjb(FBr1w0e;`JnF^B>e>tv$BZXOC^I z<0{_-&PS~cSxB)Zn_HJ?u&-RmJ?)8f{xK21V=n}Bn4+BQ_?T8*3zUP9A{4j~bfm%By2MgY zpPpuQ)lpbY>Ei4rA+Slqm)l}}TAtvt5Bfxmgyo45Dxm`Ul&;HgvX|!uRW4%E@32kC z7J3C2ZJ<}n6BSnZb&fAHTB|MVszi-7_Ey`anfwuWDz<%IH-BkGl{{qL@@Ifqrl)y& zok7pes1uOge9q)AZm_)&*(Qf*fo7CS{Wi{oSr{6&+MsDgSk@9FPoHdIR$T$RwVScZ9TT>xch`pNhu+rHc%k zn@!?*4G^eiN_{5C{5A{Yfi&hMYBRY8@%d%}> z2W`mFy&$)dLCvU!K4ty|nSCGXdDoxvE!4N~@GUmktGjM6SowAv?+x91%XqU ziCmn_b>Z8xAhsszM)9+*UIX5mhb{42Jk_^H8|(G{vC;Q6djFu_1-PJCO^Rtmw^47U z;4W729hlfeFmRHn*gFM0 zq_+_Ux$7ND1LMuEuNsuhwj}p-{74^=;;Ji_oY~l0fyZ-2Mpmz`?}|dZo?mjD`Vrl4 zBUxPRmsp$1$&z7|nS7xAX_LRQ`5UcQ+1#GuO%se%ifj0lz-Imbwtq3?T8eYD1>Hi~? zhR2ZX*V`!n9roeJ=zCoLOz&N)$M$jI`$+crGwwv7)706@8TO!Xr%w-0`_Bg}&f|+8*%bLl$5naD$2A(#(A0?g)IZtPe@LnRC+PrG6RdazFHx@s0 zXcPQQR5qjf9TEH|z8(C^TY~?&_NPnusV;}#W>m1^4~X2<&j|)!|Bs{k@8in>@uR%u z^@lf+Q&YEP%+zI0|5Q2Q6Z6u?&PmL7UnRZ->FwOG?QVkga9rl#s42lQ9MQp@+g z72>}e*1A2(x)OADDZzI=ggogwN0@xq$45iZ%NOhV=zgSZKB_>e|Ik~wn(Sr$=WW0K zi#Hp5Me@%lhsb1M`q)*8rF_|sQkIYyfq4qK0h5zo9?V@4#ma%kk5D(xGVE1ECCCG(l8T&cQ1-D-X@9hPQT+doIJy_1~4Hkk~Li>!`d`yEVqU)Yqb z1e*r5mrSFu{ff7Jz!C|R$nCrOURaEm2s^gd++=TSaL)39ee_>sqP`}Qgd7bj&X!%CM&Fsn4%?&SDb((H zMaX)%?I2;L{Z97q6K9M=J<)MTVk$zFR472n>~DLwxy1dRQx`1R*c?%O>=Eux;UQ3n6Jj}oz;t%mj zw`RC^8<)jJf!pA~U8T()HR;v*R7b(_jlHQWbrmih)0k~s{DO+4U6BiX5xr6bsla!6 zCBKey;Acd{gCM=Z>3DkG+zV18#h=CCL!gEKxf#Rh0u4-x(x_n5 zZSPbiwK#Hd64q|iyJ(|QrlR%L*;vje>L6bDCCOn(!`fB*8J!$yJ9EEjJOzxEW}KVG z;Y;Nc(@$N^8JlODP|Ws{L)fuBw1zL!m)sh3-9;WHud&~C#!c>|efrG|(Qj2}LTrwq z+Qg4#?$fU)%(Dx}P0be4)kECnscY%C=-!KLVycG4)Pps}$#3nYY3(EFG@CBIrcKZ0 zT1Y2vHmHK-W>kd~ZDK6ps3ZFsnu@jEcvfM~CVU|xk_Y$M*c0iQ?Em=QUL3l0KO`N= zhkcNA*Ncw34SLoh)t2d|#U$7HE!VZ2)?>E$IpwgM|Fa4bhM-gs5~yDCWOyD0VG+lF zv%(!NOw@;unjo`0@yCHUs;n;0sSlzq)SeB^8`;%-QR0)ZSw@tiNNBz#))ad@lN@gU zefVt&-ZndxE&NwrOAj^-ka8;bLTcJ(?jQY}a4_HI4sj1KC~@G25LmID2wO{tPS@#X zF>$O(6Dy^yx$#$JdSLoi$gPJ9Vf~CP&0sejhwy7~x=IS73Qreq#&UwCD*sXAoKx6I z+)UFVywDa^R5LBS=~g?v}JsSvS}6MPrI0Ao~!+HL-fqu?%XjZ z)l)r5myk_POR*{yn5QQdK%F6=it)XoSFd9&9QMGQG9uw}eOK|JUrL*dQju(?P>zgC zwZ#)CB!%)3Z|-#pnyoi_r2QSR>o2Y{&_!jYCfDn_XE|vr-TANM1n|F&uEdv%& z3LHkc^~xMc2g@I~@~f=8?n=y`h_35KKBtl|1uMR(2D!1-d&=#7jZr2v?dU-N?sX0H z3&lU&HflATS3Lc7KcMpf36&WYU@#nD)u+D~vzjo1{2N^PMZWOt)+*pq!$466!qp-* z53zQ%ru$~}mXVW7FEEWt!8i~5W*Y6-{7lF5v0&NRB8S|whCFG;ur!Yp8wEVdsCn9R zU=z8+PYt>QL904<)%IhsY3|#cb*R=mZDZ87J1WlfNln&iBj#pHjqj2AQS+9g2Bm-v3M=g@XDhgye-oQvHETbXK24@e- zbEqjdNZ@_>0LCq{@o{+Q$Z=l*zwv5grK-tt#RV5hJd^HtW^ZH1Q>?r5Whg0}&LxFC z_(g*DIN?cTwxkSJ%M73Q!*65q(V(z~FVTbxABWx1eO*6Xn9T7Ec~JVGh*s04kxX(E zM#tAIpZBnau(3$%^z^jd=6!hpOQ(uG9d1;y{J5)Lv)DU_-O8`jjiL|WM6oD!!qnoy zuWF>69fkIt*a`7OBF!pW3BGocJYeoFUx=6|y-(sZ)P|fiX`=zv>JZtzZ z_O#I(pzgNb99OHQmwCx2{poo=&mt4?(l(xBRk@oJ>qU7TLjx@xBsuZqNuxIfDj0KfW<#UOiG#~>c=*eZtorW&-PtU!{skb*?`<7e5W* zU%Q93uyFh@Um2x);ZVHWa9GBrtHYI)ckUWjy*!5P;=d=BdpXm_t)*B zOecBd--!2~(D$`jAVBpC|5FSRp6wp6uR>MS=iG!V7*2x?VD&5UDp>wAwmYiLvE+50 zCBqDGVaVj}H`k&}$M4|BCqZ7gFFSq=o1Rx<$~XT(Q(Zm}Fy(m~L*v9+W0)@n?j3Ge zZ7HQ!8MtvI#{^w3lLby}Uf1Hv7CYQCT0)3tllST%G@)g)g^PpCG=em}{@zk_*>9_U zU6{Her>8Eic|5z{;`n58+cVokW5EjNGvgBy1Y9gq?=8}VOZj8z9EZG~*}L=!81O~L zfKzp&9FsFR#(PtI@smsE0nRGSJ%+hhKDWMiB4eG6;j1^QWjK>VKg{59|MCZhnc`v| zHf8;6R@y#OSG5O>s!iS1rWP4SBk0s3&+sH-T_dstxth4b<66D5b<5YXU9o*L6-Sdf zxTc$ct+8z3xO>UQ`gRS=*T6DlBvqk}gh_d<7AIn5=HxbLwo&I|hfx@(b+zS{&+sItE8S90P|eBri8v>4=RwVJfeUne;TEoN zzL$75cIiPDMQ@FE7jA2qPGU)G`>?uYaK$!cV_M@uifa^iRRuq8VeOt&84Z-=j<6uY zHtu$4V}8-KZ-|J5n%t}_OYCjO;-^Fq8mW9O^dmV=#7gUW6z2OVl6*5*emhD-iQnQd zg>x|6dqm?6)9MJXG!E>iwnPIUj5>a>&RB$4#ZpxrLzC7|sQ1e=trK#TP?)8AbairY zt25eSwij#?7&FuE2INd^M^oNGs*tN_Xtw;D_a;hG|cp*4s~6j1v~6|M=u&E;xgxof7)T^ipSlso4l>7JWA*+ zC=!q8AL;NY3-2*5GMP)K#lz*7Jy+2Mqd0(>X#b z*aA<78z{i?bA;O0?w~ZjUicDz7SMtH79pFv#`y)e9++oP7To_}kWrc?rJ2LbC|^3V zt;b!SN

2t5MM%G*XR(^?CA6)?%ScCxhINpcl8^edmQS>mB}yUB4IPFBA*^p!EYu;%QNilc=-pa9TYPus(s0R!goi~`75QvVDX8FWt@r$q(4l_9W zZ7ZI8UMrZ^G+V~Tu3Yo1t2=3K7E&lCw*KdT>=Q5D1|{uO_S^mdPTtXhPcrE)4~N0HfLNIj|;trgg^B^fd0R z(RB_WayS1op_e=18k}x#5xIEa}#{WVj?_`d)M=jnxEKAV&-=7v2VDTp}Xu;G=DEt=wQ}4{-uCtf|7_u zalj^tcwV~oW+ypamY5eTKa%x6RcJzGaif8+V%>%#{C4@}dg>+f5%ZU{I%S51hXaqR z`6f75@(Y{m=l@}pdf6C(!%vBEzw*1%({>8s>IiEN$JcQgRl-sw*miDGd<)^_+8@-| zXOo-Se=0xkI?aiQi+M#;W3vj{J_OHTINnY4hpRAb?wGFuligNq?UmkQbHxs+*&tkH z9ya^#l!`a}y->O;F|2I>6?Usa4S$6msBJ_a*b8;cx}t(0VAJ794vk#K+;!g)f->%v zB<~z7kTJ5Y@vHP|j8xY__m1dwwd1Q%@Pys%1ci0uf-*~8ZOU=4-NaL2DqQV)Sc8~L z;iOZCVuYw7R@D?9IJ7a{-gR@ZwtjsSV?#Kuid0@TTFu3G{vSE%$Q!`VdeU)Mb72Ad z=k#0X20u6o2?ql7BJmd@;YH-e#Y+UT$BL)Ew;qyC_I=|RTRliqPOj_Q0P)zU>Adu_ zQD$7`N_{x#8!s5FUC+fT&K0Pd7&bOQWjjlu*U$=j4etd6nZm>w6wsK>r!Vv9%X$0` z(<(ojq~~eu`gthMyufvFSYQHLo&B@Rt zyVbwayrz?O2___u)CtxDt%s2;!!(}Hl>D--pc)}q(+-WRwtvh-04eG!^12?flwM4Swj31a<|>|C7v(Gvh1UpJzVOyjo*>HGlDsOlgs6 zeLdTHov{wXzE$ldCay+ljP3$O=>vZ@Imja6d|3G0qJGU6{y@`Gez_?5TY^~V24Y2} zyw4&ic-E<~t&Yp^g{$P9)P}ij$(e4g+M#-NZ&9I*qwv!ZxanioA!0dN z9p=WnO%21$6E_m!A#rp z#EvuFI=X|^j3>61<7lZZBVbPKHe6*s1x{U}!RY)q#;JJwGg_k=De)ILb3Fj*j~sY# zt=3mk_0>`ZjdI%8fAL?H5`C>NeVyySDkb_lLhaV}RSy!u?~^`WEmrEQ!20UnA?96S(>N=7f2&f(=fMsi?xLJ!1K?U?z6=u=xj`6T#<+m9`NBs}>K zlJHXOnd7Pxc2tdbyFE0@jUR`e_{ z$^ZCjDLkC~w(BW+F-A?i>1jHP{C4jR`bB>8nh7AsWu1KuZMX10hk+Ipt3d)e?86Bu z&XQbt9HR{#X>LR_xin=xdx>UtcpH8{B_Rzdb3sYh&>*mo)D}cjz+iNoM%+mV7T*&! z!<{w|NeDrT0H|vcHW~*vNnU+@`YS{uK|L^puV);ce_`^Q^c(`OF>URP8q?OELTr^u z!~;cXFpPL`m}Wd`+eh1XWpn7z9^c!z^eM!v0h9O7l@W?*L#wYzD3LvY&Df;Wy%pi@ z%E44FOemat3fJN|1=H3}hIo9+>rsKp9Qm%YGv@(6P zk}1S{BmfAH=M|4@7PkUZ!Y*s9EsM62DS=5At%Xj6`KE#CWRGYEh1W0P1qx>}MYb~U zruD}evRuddoC}7{9w+rcCB&pZ`Y3rqfLwQ>(+e^* zYQ6X9dXzog;(Nn87+;*D&xeJWU?CLsYi^W-w2%G`W!8+M))FTNV1cZr6HW&nbQLtM z>0vhwX*pQWuc_(8b%e(z&Shkhe^|t!17va%gl|KAaO+-hj-n17OUOZwB_B%@K^)dL zGd&IZ;S8PXO|ACYukF&6(*zIN92>f!)DJD%B7NT<(egsIDO6j(oLz@8 z9x#41;fjb#idVIYJp9nmS<4Qrh958Est_ykw>mzFe7ljCpewX4InJQE#1RE+gYRlF zYQ9bnG(6S+*6O!4ex-&SFX4>kJQU1q!qOR-6LJ40t+tlOPmA#1%8#ze0PZ9h}J*90$kIN-!Pk z_)40vZBTt2BQX2H<)w|C#m5}$~dq|)a8!c+A zjxbQ62Oz4^Z|f&1FkZbebh?QlWT7f~5lhQE4I$_v6!!#*_dECz&9daK#gE%G7dT9N zO*uJn&~>jghQFv4F7ts*41mI{3f3K&612*SGFx@e)85~Ztzu{bt+mh%yalx2zPeZ< z%zJ+G2;EnNnz;kOarEX<8p0uoa^#8hB5rpjZBt=_i3^tm7mVAc@*0jYJtuY*L}VQy zLY0lm&|y@CS{Lg;Y@2bJD?X*Gx{{k0KXa$1WO$-pDK?d6OJGD?Mo2Z9Q&_ACcUlL@ zJ4Jaxu$iw4v#x^2zaz!X5wUHjR%pIHLajuiKoGdW&= zQtQdsQ8w-%y^lIak0xIG+gL?oz7jrW<^?SnRBYI2Rb&&ZQv;>*iG_GI3fhfB92FwC z2{FX>ej_6yh-G477R$Hr^3^9PwG}HRBHBGeap^c{2QB#tJ;7BMLk22K_GItkCx;I0 ztvpw_BWjj{SFl^S!I4OvAqEFVL*}qpiQyG%Mzbgb!y;%C`jC%UvWSH~;oAHplnd9< zL}PTDfd81Ed~I$LMysInIb4*C2Z}Dijpk4X`r_3Zxjt*uX%^D0y76)g|Mx?KNp`-m z*M^Q(u4Uu`3tE9|;@cosiB6N^+nmLF>te1sg~$5(ZIjeG9t^NUfqMLP~!PnKvRlF*Jfnd6tlH}{%R3e>PKmw ze&1ebpZpzFBnps$2Z5ZR*8GfBmuks9Uq-*6YYO;JquL#=PE67V%k@$Wqc9)A>ScT?@P(Js z=(FP-$4RI?VjG@QIIhRZQ$yn=KH=Efb~ak!8m@WH=FC&+tIx7sThwUkj^x%w^|;#h z46#*~YsuC{)5Llv+#}BNwIMdJ7<&4Ko^TJt;WbEXVkxh{Qb3S$AF;C>@gny+BOO#*;}`;BfzfG?{OJbE8*$8$2;wzRnV947h?wH{WqXRa1;`K+ zM6XGUe#L{pBu?4>t}|qu!_0hPp9TsJ~36JH| z@7JSw4a)D)CP<_pK4^@BCd34U4r2l_M&+SQ>#T30*84Z>I$r@)vh|B;6f>$#xGX91 zVy|jjexBQw|4djX-aXs$YG(eH^fUswI_(ED{~-2;*n;K!rJ0ZJ72(69SHu6RWbkcK z*CNIBGFp>zJ>mz#njoNrIJ0fXa9-J6Ty=@feHF1ymC#%PgUNDd*U-g45#2Sn6Dc>^gO1TSMlig94| zkSs)v#537#!YX!THlU7b>=-3prG=Kt6j4!W*VW4QfI6l@*X$~I(&>srVT~dk;|>v_ zYKBsm$U@{{WFp>Qk^p17+-|urgT=SMM0yajNDQU>6_!_YCOOU)o>=$Lk!soWVVX$b z8S8SlP|N*hTb4W_W*D9cYEhDC!cE*n@EGe19wUYaZusgMLL=6L;5-E143$rtC3o+<6G0g7~ z=vvf0NUGUTmFg#2++lBRV-wgoM{bc*sL%F;-8OacrM2cd6LSU1m3azx+*OxN-e@qk z9SZtzS1ry4MtOW6v+d90vIzZGXxnTIb>(fVedg z;%-uT5I1Nrun`T%QNRlW;e|N6j*5=X7$(t?nu@d>c{K{Z)S+p}KK4&|5c>7h1L3O> zy{L*B{ZjidwW}%|nEgWE8}9`~B|6r#Q|>x{8b7lr6P~z}&0j@Yj~}+jGxT^gk3yYj zh85gAA$b+i@oK&yyo!7A`kc;3@j3#4ybcM!p7V(TFC^Yfi2)Orf=>%T@s}#b6|$8k zZkDrb_-~0rk7gE+K44zs)sCB@69k@!SHr0{0S@o%s+8`xo8q&OT@QPHV*6uf*}$fo z-R7>vzZZ)&&gfkijHOETwa`xj^;g<2tAmjcKURBcKa;#aSbp}wO7O-_x5Gp8$o6%@ zHpe!R+3`wxw-~fzyO=ZKd@N-+BT3V9H^HtJ4+^TGpJ)t4N}1S;?A;k|XBgxzkZ-AH zB)dKQ1`YTBx1^(y4)^SE8%2$#&}2&{9PcL3p+B+DH9S}IEQWV8&#|h;FP&B~4#_o9 zm{UpIN$mdkMZ0rz<&Mu^B@h?>k;nhdJqXhj?p9${%2qoKPZTKsdNflVl8%x()g%lef&|}<69^irm}bFy8S+LuE96ixKJ&#Ww|jrO>+|fN(+3% zLUL|1an&;*HJW5JrXA+!{aNThkSQFss6RZ~$`6{MUXi!}oFaZ=yU**q;CZ8yFbc=j zmO4@nfI$=if=FTfiH7{jY_Zn8eK&TmI94Am;K2{Gj-2r3Ok~l@>K_CO={RNnvifU2qP^1`OW4_6VTT|o6Zn@}JljE3( zoQKI`n@V?RunZ$@T- zENz}rx>hAr6DKo4krtQrLIzCXq|K!0k(&KK>rzB{fe>_;xAj>o;!-HP=cK{BHzlX z#WObvZ9Ivvnmw}WX*cL>S81TMZi3kXQm4OCl39RtJ}JU+e!L)`=il_a)Ia;JK0ag% zNNH4bF4jXH`Jm8d4LmA;3%}~M^a5mF#%rdvoLz3o%~)9)-am=+TlPSsSIIOUVHx;~ zkiaOD>(M}{qvA9MM&v~CM>YZI2{y=h;D@l_&Ril#AG%4r<%N9A$@Y@Gy^zh%uv!6t zLHz>zS|L_6Wglq1s1MK!LiDe>&WxR~+isd+*}i#^TJvm;4T}@0i!+zHs>NJXb$?WK zjUK34OhB@>s`sMuYVd5La;FeZUn)F&nj_+$b@uM2kO|L{nb{s~89EdZI=`U2lN2z(d^Ph2q1^%1(oN8QH_D$oh)@*I09@}vR8@1z_Sg}#-2|F&zVRpmu zr7-UP4Wt!j4{m0#GdWb~MUe?uK9>T&;iE==svi~&c=5kE3u)sx)6rbpp+W#YGvn1t z?)SyrJ(|eSk`3a`cBs^`XM9Ulg&n%!N@__D3yBD(V3K8l1{$qAr+JkXa0jW!wuJCP zCHe5R@D^NWi!v@UJ(7C#v+!%+A@kEY5q#le5o z@3SV_571cg1Rw}sB?yJO(eFDirt`nz+Y#RhJ5Z{@>WFHw=YjA;yqq@uDOnyCKBqtz z_r4Xri!>_|w(z8uB?U794su7ZoM6)%zuf2s;oT^4myTfl|4|BNLt{bp*wC266=;Nm zyN%<6q=2rnjU$4G+oO(Ib8ZspF^LEH1yAfCZ=fXdyX^E~%b-J*u@wfxP^Mc1DIv76 zg?*p$)sb)d-Ql{2$*y6G4l24O8}SDRXLF0xN#hp$^2|EI5#w#`_l1wMlam`?Y{czA za`%p|_0DJd5Gy^p*voI)wnB`lE%sPMw=TXr{NMnfSDq(`?#KG4LDrOb8(nCye8JNa z4iHnQ2PLi)S5tVDLqsI8NSdxA4WcB5|MD^VP>s9s3ED9xfRj{gdsFMt-_l7C5w9jI zN~A|&#ane&IJgxr4z+*>Odr3fPqF&RO-ToQe+uAIF{TTPjzGn@GfNCdDiJqee}-u| z?%b(OAjQ#C`cSWHlyJ%&UAAxL&mph4$HG^BH!a%4fGbPq_y&B5}lpSzAQ_ji=Q3%IuZF42e^(8wDNeI}J@ z7HYr*SA&LwfoxEEr2Uri)a@m_2HZ9ojM2CnBp=@d!7d#P6?dSFOYMur$f7Ju(e%8|CKfX-SOy2zXlKoRW8hd?$`&H4z-n zLE_0f;OXj-5g5N~_*OjrbYtpM;T76};X3l4US`qE__ZpJ7EFx?7ZMngP@Q$n#~Huf9?B-clIew>!C zX^Qowa+o^3i19r8S-u>R%1`)CsUp6emYc9tTV14(r;0xZiW06`BWEy3QUF1M)k3^s zvqGJu=NbxN*dQ4fBCFw*n?-Q*z#cz>bIuVq(b)Jn+m@|~Vx(pzP3}fbLnSsxq+6oz z#=xn`GjH`V{2p5d4B?$Wd=!cH#3Av`KdqUwlF5h2%sn6oZhdU7MBILbcE|n|A$%i; z_1A47pE)VKsdAZV#4DKG?@x@$xFh63OQoRX8y7zneuF}+FUu_d!Ben!GLc&UTHw znyn4~yA$B9OU$!(5DzQLGHufKJ{K=>3eWeMm-)&T`1h6meW8C}?cbOB_cgp{@}I4> zFvl67&*UD8KfXT%CpR;iEX9xmo}4^AjUT* zYV=on|acsZ$u{MIR5WOk}#6b_Ipcrze@y-dEg zDL5gq=@{{z~VCX)#UeDd+&*aYq1e7iAxk1lqmj_Uo6)ruk=K-G6`DW|< zQa!7g4~;f+lRA!mn5@nA*lf*IxMypo+C5t{E$+El!J<{BR_}D9j$h(|D_ZlrXhOlE zPoYg1t1{@Q#rK3zMQiTnQ+?*xQ>^Z(@QSAVnGGf;kiAHDzBltd-88K)%NE!eA(K|v zG9JXQ*lSbQD{Ag=-`wfeTzAymJIb0no#sxr=7t4k{_Ik71J>N>GQ&fVzjLxYD z019S<)TV5%SBj4M;-%}fJ(A9hj%e4TRY*DK3;ZDUW-+ZCu$={fra$GbRqiP?rOe9o zK{9bR0QlH+r4n@#g0N0gkDYQ~ZCN`LQytu!)Ihx&PY1WJ9DQOyN>5l>77rA4D@2v_up!ZoBh+&^yPPH5gHAG9R4Stbp8q~-UPO!71Z-mAmFtk>|;mizppQS zPua3m5vKU);dJqmjl9GEMqyftmyFt2l{)95@MUy^F77ge>+7>fdf}~nxn!l`JXkSK zVCbBG*Si@A!}}>Eycd5_!uv{jkRAZv6TmmNy$IhuK_?VP=udEtCmpt@-v-NnXesd< zln|`=w*Ma2YuLqGVCQ>81Hp=R-W@!O%e)Uf>Awb^5Bm1rPzYXwXOgAFZ%{(8qRM}d z>ot5C+o^+xu@TP^N;OX6Nj6SjA04M|pO$g4r^6?0I6A2Z%Akx`waP@_=aheU{q0g< zBE$bZ`}cR*fBzNu{}?qI{&8w_{e8cs#BWdnZXEu5T(99c-pcX+vh>IX&)@A2Px0q} z1w22dMuUgw6b_zmSxWo{B?K!v{P(zC!*<>rJn)b;q(saD9`d+eNxn(H$NH5XniSJc zLU|8^Yfsi6r5e`_$sa~Wr&C^^@Z>31hW>f5;Z1VB;p>PS={rq-x@nsTR2UbMmaAv6k zE1A&9-G2=~3_1_>aK53C!`2U-@(^ECLa^c`h*bTI>ot_qj2n*w^+Qv5Oh0ZXyYI(= z@{8ogqWf&5^gddT@n0yy0A4A`*4-CBoHOs&P)NJGLmdl{?cKc$yWSR;YEx!@r zaCA+%?A8(vUH|@EI@kgGG&-0>ONPH5ONrm0gkZ%l{P(zC!=Lb0*1-nXKP@|B`nN>c z=$`~l_0NRNGSXga1*})+E35VD*{D|yCCd1B7Gg&ke>PoLd3fJ=7j0O7cB3K}Jt%=# ztM&#x=rw$RxBdGgQW?{q|57&kBlf5MRP)=E3*C^pnad>-eW|3ojVb87)oQQ~epO|y zgWul2gAd&D7kBUjz5{Qd>UABgv6T1?N(fd|`tNbQhJV1mQ`SK@UYgQl`nOfN=wGex zUmd>~owYy`YFEtYW-DSH`k^vghfa!^(ddXx{>wXbF7+7&DmJr?*rzNdeuEN%71RCq zxL(5#s`Y3x+Uycxj_FMWSuzFg=TUrP#3$c{pD7>qz!ihioLdLZMM5%eN(bgR;jHy$ zHzLm={yJMq&*LVN1-fTxD7~LZ7IdzpKI_0?v|t@rVkz+(ln|^~;J?T98h&1_kLiFY zaZCq3MHag}X(Hp0(MhS!Dp4F8n)VD4)7rkG!76I76it_4$ehL?WneTVxjE<*n<%w3 zG`_b|F}Ty{YBjFOcw+JM;R7%43yi2{3^4z#ERKu+)E*^WU0z1Y9&w-i&%YRP7f_!e zPSJu5ai>{I{01ciD?Z`B$MqUc<4q_yL?{Tl=1Y>H(+gdvS<%2FiW{6eE|UBP7&ZI2`cw=+v%l3s&~r1 zJqs;Pb5yUgxX8-oO%rF_2yet;lOgZtZo95y^a_%@?RT9`#zucq>&C<&soAOLHZ#Rq$|TVaAj4M`3SBy9`4%_JSfPC^w<8*K!wVD)(wr zt{1~?Hg|7$mIT>y^eR;L7}^R?*^R<9l~|w}!{d2U4g58Wra?{(Eukl`(sNPY z{C(VdALJd?`oU=sw2WusBZHNdJXI|D_*oW2%(0IaTSL$oi{Z{h$4ZX&B9{7|rr3bA z+^JVg$31kL@((?u%2lDJ`-*-&puT93nP-p}&W}IB5BA+J=x)#WZh7f5{AyTh)%H*W z-(bsDUreD9GMLawN)xORp8a8|0|0bbl?0vVXze3-I+1dTgXcr!&cg1s0VT!UUX&2j z(M`-5u!~y;Dgbv)zBL%U9Z&Lko6B%J7 z{Iv#!*_Rd&?GL9SyKB*D9s^DztS0MA!4i*IhFFNDtm(EE@KKo-MwtY1FzrS|YH+xt z1HG$hWt3s8_>~`NLZKAqMQG5btkJB#8bPOO#tx#djL#rd%8QYu!nDfFTpMJL;}PK~ z!xbMLuf}z4S{f8CH6!mg(Mric?ly4z9r~v37go`}^=8`-Gwwx`9tE^HfT6 zqWmmjH_;@CNmM|{ncRj<#}nL{=GDV`-GaWw^HLB(Vx#Nu6ZNpR5y4r~l(ePoq( z3!dLijk+GghgUH#&#fQ;+sj2bvrMA6tVIr2;X;Uqs+Z!SKso4k!j85EiQYQYLP7ywv3Viq~&V-lQhgy`g+mK58)?do{};m*P;ThH)i%pzC24TgCz3 z8b{uktvFpF3g=vySe@!>e>9u`r&>>w72%WOaSWJ@Q=$^{S)x&AVY$v3vKUwu)GQe$ zUy7SBbGr$%i^IkvI#4Lirml)XYsNGL-|5ZtJXzHcT(kN8+%~$?r6 z_z=z~@J~;evJR}st0;^_@G-Fq_Nt==?@?KLt~x}g)8WaJ3G8y**6FV(P#(eYEMDHn z{hh(wQF_q^vB8t5Z!@gM#n^1$k)G)&wT<9keg+g~P3MRn_gvQ;Y+U9QxQr3X!Hpfb z2r%HnXPALdpb`zffuddqoh$fP0Htx^a6n~pZ&DT9t~Vx(T*C3eqd$6yg3Y`a?q`5O zO$U*3MEt!PB`pXg0DC0P`F=nL48mWn+(}lP_|c%?HQ`o+Z8^@E*$|%X+rq2iTusV_M00?eMQ! zxVV&0CW3VFo!49BpSHw&slC(4uj_1O`&#Rm#n(moE|YE4tvZpdMQrN34mQU+sTBR` z>#$mt%=bFdc=6wT4yEcZe412cs|REQh2m1J(~-BD74wcO)i21x_~(+?_?c|}vP6C3 zrzM=A)6XLGAl;;kznQ|4-54DAX>I{)v{2T8zn&){0Ep8XO8$artV1MA!mQ;T!?6howky*j zsFua4zyv%1ORQ)shZRvoK;wP-CEo(eCutt_zaVyt6Rl@Tv@)o1{#=FOycD!(I2)UV|^Y-j{8O%B~girfm_s zTu7SAEG0?x*QyLjEuw{DAF zw$iP;b>G*neLj!R)@|)J;a{Sn1`&vg8WnWL2qLINM0mcx>pqjjcAwAtyl7_5oO7T1 z&vjq_?(4el>*nN|hgEDD#WWR95GnJaxNMJ0p3wburPm9pmzM_gO^0>3lJ%jETJ)e^ z-#loJYI+phxmN(;*{`ir0ETD4YY%;Z0p*g54}0HPZ{mve!BU~-1WM?82z2Ek6bMFf z0nZm|sj>}J%ANZnH3uIkWv}(NZn6!Y(uh<+kKOzZ{B&#IL__*gjna~!ruC8f3axR& zme&j#wH3K&H>3auT^67w#ZN+1^{g$`Q>9WASZbw9+TFMD8M67)o*@jAXMq`)dm5L66>&vsaqs2msXEgHde_HapmY^_%-6(f#JAm1;Urc>5>PJjX4) zKg-j?8M+I15!2AW;%u`o3v|%4dNS)_V11v#S{)(L#=Jkfg~+uh1tuvC0{FcQT}pYg zx=ty4$**X;k08WQSQ0pGdUPlQyeO4BqbCCP2lQ;shz2^OQYF=SHeD?(Hj6oIwWc-~ zk0Ce2TX+5#-WqXvMn<Q6{Vb=p51|G;vSnkE!ixdrJW{V1(Li+{__Sv?#(@7>wM>SYlL-o5|O zRZDRJkHn`Y6u)=CqF1M%OxysOF_rd+h$nk4nci_@EF^V+!So~^Ar8l*5#)m9~Y1LZ#PB$8$Vy$ zm@3@*5{vVuwo`-&n#9Sstczi8d^qQ2`ZH}?i5l%~3LecKAs516=eZM6zc0qLQmXv_`3H&Hnn(TG9=;Bu9KA*CFH3~hhXDb6mVV`+ zPS;cMrr`1P_BXP+V_#4ruR)0;N;?aT$c7eA(LzTncZRhhu z0J-Zn#)u)#Ypqse^FSmrz!kvl+eU=ECq9Rw$P<0K2`MP65S*t%SJO>%x?aD==O+)oTw;Ee0y1?pkXOYj=&83N;V zmVxS5Kh-Az=;E-wpPs&1xbaLij)K&Lb`ul0{UGRvkPFS0^zsAK} zKL)GdH29aw_?1zK8pUmZ^5iaI?$e43dPZ9k7o5rxu9eI$XZWUwq@j)0^Du~!lr_de zuZ4KiLmjVhrp#kES9g3IOr5j@go+)`#oqB#g^v4*wRn0*>ARI+Dq7iy#>yf^%7sC7Z@(EE97FBTv}0J zT9AL|9n7VUc05b@xqi5O@`O2z-0S)V9LrV@f@q0gn%XdqR=f+~PBoTM@f01($~2Z8 zu@#^nY%Jcx0Q4raN$!%vjp0?Xiz5zNLMd@l7K=NXVp}C>4mppnPW{xup9GCr_Q}uAw8xIEeJx9=`Z$fCWiGO z(F%|fU)J0_Dw^OM**oQ8ZnSLTB0VxrsE@(JqSG1t9iO9G%s6+P1@>#y-fdG5)f(M* z!Mch)N$%W;vjAR*xyHmTtT z$X{|H;I-c-!428#nq!QZ11qa20Mj+QY0{H=0Ap8?ueE(KZ z0Hy#DY}dy&aGozlQ1d?gL6k6_1}ahgUo8_n6J=r%vyBAar1XFgU#AgCDQ(&1O{vs# zNW^P}<+NZzFF9oTI(o<0#s$(FN%CkcgJh?&kcwL*uGf&oE?(h}k+vRS*0=EoIT-tZ zbrer2jTcnGrL={ypw4Zw+QQkpq%i}^UR$J<0$*)`+ z+i429wvCO!?xx_CY_MN|-i^Ai@5l84&eS|L>)DIL+}4q%woSGSaJ*>mBs24la-&S| zzDbZANtyj#WRwx{$28p&MC<2!r%n3=Q*l~Z4K+Thss}YQk1&<3#;Zh#8@bhj{sOB? zd#9elTc=liqAB*KepT^t`m~y+Siw)d*YWelU?2_OLj4|*3LZP^#|9e-B<{MyR7kQ~ zjlav#^CTOOCy~lo_8CEyMZ82 z01r*pcJ`IAU=23u$2QpNBwaX~95$N7mr~~Fl4T;v_;lT4%f&8r$M8X&`lu}$!H2TA zyaSaV0$c}G*)vRV>!DG6fMy|6@Zqp%RTxkwe3%`_(~BcvqB#;igf^W{J=5{e>7b{C z4yb&7s>kcPRVJG@m!3tryT!Wx@98+Lw}JF%TqbW%i}6u$5-N|ToS8y1liX{C2~5!* z%oY?1=_0X_&Z8$f9xEOL%Oo=XKW7ZQr0Ph>GFQ}(#IAXox{ZdxNgddyyi zaZ&?TgI2J{*xyci!byTHN{Tm|+Qd#>O$44&QzQXyG|E$dPM5lg+(S+L8?ft;?e3`cdJ=>xX@B#nja8EdPD4bw8BbdQ5M<1-jI{&8tVa zn16^{_A&Dv@Af6s!S9({yxU{Cl#<08fG{y{Lzh`X*s{3rIo%xQDR5r6O>MobCSK&D zzp$80naSVhabHYScf7=zALaYnocA{e^)bZw_IaHPqY+Gh|2D0G z%b(|Kw2V&B#SZcPto3W=fcO3T;XKm8y&rVIm%Z-q@X1^E@)j-3qU7SB#$qWvNu*B4P>JXzXg_`KPpEd@g zQ`rTUUOp-gjnt>CmX>h@iDswLXUB z=FAnk%MZ9s>pl?gEx@#uVy}3eZBl^%`CfjC-=aq?JfP+ea~G(O1A6f`lddb>K+Z0B zKiI{k*FC@|V7b2A0l5%OM2)JMPn|RO-Pj^1P5%xhDA=rmfNn?y-E7=&0mTNq&PGif zFnmmyMNeDLIiJD;s4P@S{3)NeN{1hg)?rNBLGK6uW&Mzyfoj0--_ub|=*?9fr%_X7 zFLh2yGy*(e70Hj812^r}?G|Z8Q!>?71kgHuY2Eq$zgmq#jJb5o>;62S4B&PU_>U1| zko(`#efs+7C}MnCh_Ot!8Pv0S2Bm?*fcDeHW>X@@wb%JG+EdAG8b0iz^_;m;l~V0K zU;L$w%j^qO<$z>I(XUn2?yce5oqdAQf4ZZFUcKm0!lAEv*3Zp{bW`YC#DI-HOj|~N zhBHrSw#x5P5fEXZ*#3ceAGrC3j-^!by>azgOpEHhX0+ZffmmbfH>>diJ!E9h>*H}( z_b#j3xKa71qUW!Sd#>{*oIc~m`<(FDb#R14eXf!xHHNXqC~qt0;Jr-SNeUTgJ2f@X zev7ha2X6~k2zK5^w(PZ;?uQ%mmmVYJR9^0te*Vi`TYAji#vpx+efjgh7sC{FC5KzK zC#&U{3oCYIv`>$O?VQsdJY2X8)X20o62nosIny=?yf|+p8NaOGGRfP!s$6O6ILtt);bDfy&jSoWdqmgJXwEU%^ulp zYuQ_2VEJ?NpQm)3t#TC#uhbDEY>}$a0iWKQi;bmWqzvBW%)k7%vD4Pc)E6hSGkP*H z*0x!$3boChWX|?C3|=*vNiGshd+HK}A1`;C*b=fJVjLy634L)!C?FE+#bWf-h2ip( z;@P$>jpSa}2EAOEdpzD)TOh<|QYLIKA88CWVgt;@j;0CX*QXoZ?T z>h{5r!ro=-Hc0hb`oz@($(4Llb@@vSSJ4JFlgQOg>O*d8K%~ZvW?2LB=nQLp?GbP3 zg~RrG|JdU-ZcGO!3FW2f728D~mGFd6$^p($oPRB=p*)c*f z{NM$QaogWe=mAU8Oqkm-G7EQ!!zWrmtxHs#W-&2@b>cwO!c>;f1(>ob@F!`VaI|A5 z(24uO(^!DXXO>Pq>UGPPQC!0ZSS>s(-fJTgt}wu=;zs?ntG}X<$rlJ)EF<2S|0s4p zZ}lE}?B~zOf3dOqS#Py?5H?5Z0%H@OFymIEcL@%XnrDV9#lP8RN{7(-S_aao9m{7S z6%xMEG03Hp@OOd23sI(8nTXcj)b3lK7<*xm7jAh1o5}JNX(CA6Bzd7|3|HC48}Lh-1Oocxqk z1V$aVv^V2HqR{1oRy~>UAs2Q9Kkw(a&Po{2ecs!k_b8_(46d1wI81v8I_ga|qCqZJ zvHIvqjh`|r0VBgzIyn|5wA;hQ@f&@h}=-6I1uUudy`TD&etP_Ki6WWb90TwaJ?k& zSKPwC-@V*zcBZuYTeuw2li?&o4SeC%ii%ZU7|nJoU0az3%iD&noaOp=U# zy4uq7qw4V7h~SoG^4b>sK3isByf%ucaya_!#3M}e z+!&jHYxD%a4OYg=B{d>UNq;5%RrCbhS(!-)2M4tx-qbyD024_GU?U!C5l4c}O8c=q z*-#i_N%oaiG0abv7-p`mI*qub!M7;p2lpf^=}2ShEpPSz(0l7>4q29&1iQ%wBv;_@ zql%;-yiLW{#o8A#y!;?#RSn@CdMlj!K3|3lnm?E-GWcl}mpL%247TOJl-WY4GGxUb zunFts@Pjw~6tm%VNk50wrCiUs`J#?&mQZM)=G0qGYmWP=eapAy zf}H?C1EEWCo)D`ly71O$Z?`6>I)8dGfN74YY&oU>bCA0zY~P10eEPz$5_fG`G8YoY zPAv-U=;xcH{*U2*B#KF`qp%DpTI$y{ASI=xFok#pHPRs8?4nE`_@Y*+2+`D%|AMGn zfCBHEbc2XTF&~ijYFt!Tv*Tccoxm8BiFyM#9qjPVMq*DjH zRVz&h?IO|=23>|RB4Xh?kqjI-@!MtB4g3hURZ2M`mxuGYvLUQ%LUjcraJr2HU-Qb)Y-RKlg{yJNTlh^BlT z>!btgjg|SScS!SoimJYSJ#Jk^0%{V+CaGYxFS#B_79kZ36tv+apn zksOuES7MVcHX!1(Oy)|80X^~CJRyV6;K%3T9lHCFaW5X$@KDS%p1u-(I>fKBFEyjA zs6Bj(u`MCpJiy<6 zn8#4Z6EF|y(;}iw8!O7$Nt<$kM)cy^y`H>982b{_o(J9gm~#C+%in@0#HH68zC#g% z-t8}|$)6~gNeuUEO6UU{Xpn4M3WY<<7l%pPu9UAQifIz(%`x|*Ji?{vcM~b9$mHk3 zkY=2LFZ@%&kHv&+6fQYiO0|n(6al+VmRBK0SSYf;Clh;~w8Vu^SveYJ#t79=(H`I! zb%@Hy(ET4Y!W~yhUW8S~A>I$zh{UxKQ$*$TfJwqv2J48s@F)&Zk*V6|C5J>jP7ZQ& zrRu~HAThj@S0yrl!XhezH;a(DX_P@>;cFgd{dAn~2&qw{GQkVQ<1EG@Oaa0VZ=xd* zV~>7BRByymN9BGB?x6$z<|eakTYY#*yfFZ;9&j=-oIc?OU=uFs(;8+Ohw|itqQWeM z%tr`g+jl)_)jBt`9b!wouxNtT;P+Su)2Y`xcKD*75>L`BG>l_6Ozg7!g#77YMb%ku zGm#%Iilw#(cobb7-X(|VuQ19_z2dD>)P^EVkdc%N9Wh<#n(G`ytPno_v7)@K9h>wMGfNu}p86tmj8v zfD2yq>SB!C;cgOUw!mWh+LBkr6k08{TVIP8Tx+M+wakxf~QJe=}_%;H@ z7?8zMr9<}L5<9|@7^bpGj70}mf}i4mgjN`vVRg4<6y3FPC0w!-`1%JALXVBXzHESr zQ}F2=7W*Nl;p|%P2j|iQuRGC7J|L50-Rp?NH!Bj>x!xyR7aTSH<^79gh;&ot3Y{{_{$ zO!(KBlt{iCJT3B2kk|ZVi`XU{p}A0PXK~t2u>&F^r|}4yb=k0qw}!Q(fxU>y;^#e! zxfClwpVAabo%z~x%oufv^Aoe?)K7_rZY4S|ev1zW&s^BbS%FKbl=b{jPJuVthzVb5 z7FxGx8JsDsepMO{Kht^aZwJIpg~lxD=^s7F^wBPWRqw?3YhN4Jm+gC${!r#3Tjs0|k`LRrauS>M<`=)M~WGbHFm0B9=%q)TcUI@mS1!dQ`Y} z|3XW-Q31l7ucbJFOQFv30_K`W#V-l=paB7Vuu@?l0vGz4UifRtg!_zdN!i27I0Iqp zkddXD)+3-XC=3gNJlBCVvw59Gj2SSSBvoIbA+b(kQp!Q?Bb?n_b$R+K_T;cbM1^A; zFO#e`eJXgZ@S`2JQuKM$iMgvQsVg{KU3br|9G+DYhr+K0s*u@$O?(Q&rJ8U=c; zNhtm;svRvS)Yg5Dok(Zk5%^XkA}Da3Yg>Y($(ONGWRVYu1CG}NvILAWoQuP23L`Qu zJH3%(&fXxsGHe;VLmnfB7g8J;Lg`3mlf_Ssh(Tc#bjz0k+6U`Dfbm!|WpDLQz$n;V zm_O&&i_KjU&-BqH2csU|yD(@!fwrbFi-j(jRzJ?`^B+9MQzCsYkj1J|s)>e~MF~T{ zXhdj(177$QFjR^_9d>YVx<<2yE{3kC8Mic@(9cxBp7C%gB*lB*j+;f%6PA8|6IsEA%tYaO`F+3`3&+3d3mQo=wau( zaj*M%*Y?ztY}8j@8K!myr)>&@IIvsX13J)mCW zCz+c1mWV@YP~jtI;E8he^-)~{c+LCmH#JiWWwM3Mg15Oz*8q>sE%D5pCCRFe-xuq_ z;LdkX@w#Vn!7FE;K>{^c^|c!2JqD#>C6C1SIyZ8>M)}rjOVb<8ytJgSeHY7^jfE7e znBra}qOgh?UhmR4u4DOzFJZk6hE^j+WuN5 zT;6A)*|>*jFUcI>90IfC7ebV_Dn@ynUud9XFgU2NrPvly56)<6BhfX>c?@B-bW~7s zV-fqx6~vq9qU)yCTqR%uxe0J{^>jQp59fV>DK8v?gHrgtUg}1*Zf>{;yCbDyeQ&;HmI_7+S?+BI}!*XGQC>wFc z#IYrmzKo*2odp%n-c-2ffa;(3H7ekBSBm0L5y0S1`7anBNK<|}3CuwH0UlyZDeS=< z9uXNZpG{%@r@*B>hrF-Rs?`za9_*sP`}|GeU@FQ;V=@wjfwP)e{ZY18rCd&a2(G&) z*y>%vUW!TH>I39C$ChAmgp!XtPPUUex%eQ5#+Op9U)4|NpT9?<#HvDko5gz`d7|K_V5!rAEC z21Z8(6)@Ve?R{lG(!>L()b8aoVBeiR6J@E5?pqmp{L#_TIy4~xeT3pJr8u(Sx7OXM zzp<}#9?%yEKO0KPe|Q{uwGg;R&^>zsnV7|UX44Q^B~Wj`AX0$yhX@L@$z8Nycy z2ktRSg&i&67VD(08PE~7-Q%)rMLe`w%ycPF>|%*7u#AX<@TJYK zV_(hu63ysa?4nuAiE7@EY+6+K2*+9g(L1?8V?Ao$<*nk^ko&dXJzLI~&qFoKDx;wh zlJ3q{sUn~KVZqx>oium-b4pZ~nFjQ@hIG=Ud(!lE4~0T{R9EEubH+gZu2Mrmp@hE% z@lIEFEdS?zcw@|;gAnpo&twNFBU7U!MiEcvsTbtf7tWMTxh7dP{E=wgjyeD(oGX1H zXZiwCiDhN+hJB_&n9Exc54~chJb31&li0MOfB@b!M+YY`_Tp;o^5_6~)g1m^%&$G- zrw+G&GZ&UUrqGt)IB#qs)lSr*?FV3jY;t*}jO|dlNv?OE^cF>yOp!8C0l!;7@SGO8 zEsqf(5E1>Zjy=Iq;#ShJU8$q(pJT+L0F4q2H` z4GzQ|cGS3?h^&>c{*sTHBVw2@7J~lCC>dI4gvmaz1nr?Icq`H=8l-RfwIhN*TB~w) z9Ri^;>L{((lWv*4hfE{bhw@o&szu>?bFMo2@U4MJ!s#=Ta|s+=luN8K|X<2;JC4*kUU$@fklqdtGDdja$CpW9bU#{u7`A zez|1)$bcU!FbCZjf9R;=Z<(;Y9&XlGSl_CR<`f%!f~{YDYG|x|9}cwStFkep@iR&m z%Xbj)#g=t`DAFs!8Y-(|E8o+FCyLQnc^?~hH2rO|V>CxpKt)6v=Av|1c}5;{LIedrb;4UUB66X>Xf^_88}Tn_i!xzVv#C`ul(k03od?_4 zGWSZR_FyJ9*c8s7w=fc}v$4&=2-BFZ-F-;+t5!3sHs~-J@_$97TE{lkYawfSES)szIA1>Oiui?LdmK;xK%u`<C$!0Y3Os;;K;p5Wy#qe{`U1M>q02lX*C3T+3f(OyQqw!tX* z50L=jazU$DcyN2PjLFIl{Z6*8k;a9lP*IkITNd@DX%egqok!K!>>uwa2 z8-_ZUpbr!uAGKRI1utXR68>beZFmjeAa<;Bl3-kcr}FGaHHmR^O@oSx>Zp@COwH>} zv*#G$W|^0&gjy!b*jJ!aXjm2RnDwOUDSJUOb{VtMOINfh$sc5n5-xTV`Gci|O_M)i zJv#Hz8>*=u^TW)(n@;1l^TAP%Z4;Zh$@}|_5MS3XVdJ#-I%CxA0}B=dU9*sAjDzFj z4$z|oTrNO~Skq@be^fpE$18>Sc(aU=K=?+f8w;oI6GXMfb8f9v+*|z+4UCf{QW^h^ zTYh*QCRz*!yh=A@snsfu2%)#J#+pWv2_qg5&igbC=E5`2=Zp25v05|IDzETpgsHZ- zLv+nl#ST~gL&XwHk~(F&m04%euaG$iZy4Rvg*Sh1%9S_~SOMeIl`OQlE;rE46+hB= z68SiNlr;5mC(6qH^yEJo)nq$%)TM#6p@i3+NI%3o)VBo#%e-%1!8$v5TP^_!n=$%4 zKfnB6kNF@`IA8HFulT7~y{`Rood-jrFLJ0wDV@`)_S=qiypay({@DD>C-A$TALRaZ zoJ1*#GipJOxnw}@myaYc%dU6aG_|h-yE6mQ>NcK_Yc{UHq1O2>hOAF;A?@7_LADT? z4A{B*n$&jSZjrHklo2D_x&@~4lkf2>C)!{zW^Z=RGDJSfu>E8#OmGKjFpCQ{ z*!5Ho{26Sf-^ks!F8=_3wpYwy-dlM0Blv*xW$<8_ZHd{)5421?7-kH64mil5*v{HI z+xA$oUqN51oN`(Uz8a;6JPpwc679YhTv^%a$j+RVB}w?^M88`eYN{( z_GbUdn=9~A7Z_eMai?pPs!qa(0mEs+?}`I0W^<%D1rdpOjNU-(JdTs}s1Hn~5lW0} z3B$cZ%B7%d99p9hG)o)9@5HjP9f3k-mJ{X?>uV(IL~JXI`E;%2#jH-(4mQR5FA1;N zh*p5aRXv)orf~j8wFgq+oAp%c5ko)V%MzCk^o?4qUD7;_)8RNdYv_z#Wc&*ww+tQDz7*0LqqLFOprg&x&id7Q_V00_1FOAd#*NHUpb@l4Th#Czaq(v6Xxi z$o>q(qT5mgl+%aH9xj2_f<~egd}1Esn0m1bAYBe+YL7CF)cbr>@Lm)97%USRA)rV| z5Rn65vTaYvZYCJ3u4;OyY9k!bEjSCrIE|Pn)Kr>EJ?^auDL%TMFlz2HJYgbwqWeIQ zr>}QfSj&*Wc5m z=uFf!1UgDT46&r!%&?b0Rci)WCZ*Usp*$}HLGz1oLLP;N{z&fEmcsx&H|et)pDb*#o&N3=HN9T$EJ~9QWxV0A<$}j;aWtiz@yfS zvmk>}e(%q54zgQ6Y2c#?jboa;8W}IJ|Vb#tTzwDi! zj#JgggfKWC2N_r2j1s7~QD28?*JiFsz2sw@WtAwIK?Z&XmjDm#l$ zd>s*F*4j-Nmrn*s+P6$7d}BbG{t=9Zli3}OF1oPH z@Xy~5^;}hsfkE+>KAq1*(t=Gx1U;ZxkqMLAuwl2jE)ui3j&G}c8SWIf_%O}@OTD_+yMRQGwj;Mc zo!Yfxuy~5;^mv}{vA0>Jf^RxlE}Zs0wHe7)(|6(I#bM<>nP*tV;XR#w2CimBw!{m^ zPtr<`tI?%fSpLXG;K3v(Ph3=L_2@oX%f`eq}xYXV~t%&zg_n+xdAub1WTP zaxDMhp!pc+xRPFg!Untn{K)j6csm~fTNQBvKO;-M8+vgrj+<;7+sV0q5BGz2i%FdD z;2Zn_ECxM4r*4fy&l*F|G2C?P1_lCub1_Z3BR1B)6Hd3W@O@^TY1p7%iLJM}nWlVI z>Ii@m)A7QSHP!E-E2e{OG6ghvIo2CcgC7jZxnB>@#MDBN%IuWRhZeWwoZ1+t)sh^q z(%fbdlE00p*oh+YL{o4q8=M%P=kUViTJ*!Eq~7zNHdKO_`DB@b#pNckWr2=l_?GF> zSX}r+Iwd2;BBO9HUNl4%1BaeU_pofIU9Q!|Dz0hjzCkzjv(w@ z?AD*38l^f!)UI5xPr_4Rk?{;|+@WPtaDWYYV|efH837WkNC+^2z8ejPSp^Nr!v;cW zxDkyL*cs{ZZv7_~z_x6NayT|d=qGkMND87ka`8qGty=LzW}U$>y|%i_e;7etppfia z5~iv3k%9KM*Ff5@@KIV1Kgd*YJeH!;frZkMfuYnRf?mB1Bf#*l=&AG-rCZ0G&UU=n z&x!cN{-igIBK5`LjQ91RwB|M39ksdyuR*PKK+(n!Tnxn>{e?}?! zQ)>H}&1OvP(mO)@s;eTus=EUz)u?G^D-IAjDItoQ2|+YHpuiBd6;HwEU@ouX>b<1| zjo)GZX}X!7El|&-YUzb4zKc6p{EotJTz)B5>3;qbexA@U3;$e_Ty#NLInB?1-USlc z{xxACJEJ6_wZ8M&LE6~8e?`I%=dNsw?QTrH@2whi56bjlawFR=?e0eIHp*1z1V1zNC6N-h3!SXqNpzA?6g^han_vBucTUk;O1O>NKmv7x56y_t1L z_pKw%g7VS}Lx0F!F5_}gmyWsfYry@wgW8b*g=TL3O75Js+-Sbya<0~K^}(+~3xS8& z6&CRqALrON{ibgclK~lj;K{fcpAtN?!BeE{`rhk;MgF6a2q-JY$jhp=wN9ibGPtFLcv;wGpc#%iHN~on_qf=oq>Q; z1zs(D$+gZR=j_c7dB=3$~M`QG0p}~5}@Ko zfIqX;$5-KE+Vl~ens)^!MwI~T$>+oKw3SZ6TnLfw+{$u#AU&zfh!0+(F3@)^7e92<9rBn=Iju4U#{ zrl+uAwDx8;{8&u#LzY3ja5FYGAtG8~mxYy*-4hIz0>Cc621Y!{Q1mMG7QXrMJbguSNxKEN79M)s;k_hH>B;vt ziwk~$lWIlGUZ9!I6>?)I-Fw%l01k6BpRnF7<LMSlZqmOVxeJyr>w~C5Lk`Y z!|A_fY&q_&ejBVyxCTFUJ7IjfdQ-Y2+D3Du}Q7-nrg||*+x&RZ> z1*H`mLN2u=xvT@fv1?I_LbU=!UDYL$y&Cd$N@#vs654e%OSe~2I)}dAoD0v1tDoUq zBFYbDg2P%TphK1Qu`ERs*Md}&OGp%o{dyZO_FSpaD1Vmhl>?Jr<1mc5P_Sdl;A&Oj z8&5$U8Rkx08@7Ehn6dSRKwZ1+Qnq z^P$NFviYfd^t@WVf@O*iye)PVmY@42VZk)cw#HuQXhYGu#?7InYUo%BQaax_E;tx| zgKCtC6`*g9XnwU2Y*SwKBr^3T>$r3JNfc+i+WDfD#MIf8 zq9HaJ=-d(}PIc3t`Sb^bzmzW?=NMaGnIS%tQ0RM9Be=q`AlDu0q7ZAHGk7B%+nouH zzO^7{DXxbm!(JvNJd+L-~pJlxaY!D z#BJaw%fwSIcZ`McsOK#_DNNI;dWY%HApScEgx5Fp$_Y(pG_ z-oswRHyp2sxWtFNu3b0-v`+j0{d%2$;5MZDNE&_6-~$pubv<+vC2&~@w}zNp?f(kr zmC=iAuyw6C9|8<9WDCKk^Cz?TN6FLvm|R;yq@BR_xzpClLOuy5xk_#XYf6mCD78uo z9#>KFRc#Ra=M3w6F$}fRAPDx;Atd%~a}XXse@hQ=@I(b5!l~cZgUn%9wRjlAm{9zp z4SFT-@;foPz|J9c84v={l5R117Vlap(n4&d(clYnX{6Xmj)eAZIq{ZF>H*1-B14wf!!Gv)+@PdDHue(;{9r6k#y4Lz}e}%{C?wT$O;qe`I%T4-(Xw8 z#UlhbY~X!`C3e6;gmEkRojTcDr5uO)J%K7a&yB74sNmnsTe&TIJfFwew)ahCWL+de zrr?D1@AXLnh#Xy8r%NwOAhFw|t*yMq>-nu0OhH_Z;X6cygPA(T?#QkT9T#VA3OFT< z)HPc6Gez=j>c?W$b1y$i>tzcownEDQ{Bk+7_&$UHR$@2ZStbZIxJdH*V4GmTnKyNt z6n!b3+V8FTd7Qe#ij(B`i;;fhji%7wHkuz8rUsoqkyDb2@Ol4Eha925#SW%+-tr&3HTlXfO0>`1=H2#bdLr~U<{-UAX0nE0 z?%F2Y-f320U7B*BD?Vdzm0qUEc5n6F+=8Z_(2Q1vH?xPfKbPvs;krzFcW-J+ZBKja zH#Ww1ki}6NC^;E#yOoQJ!nxbh!S+kYZ#3&+vb<(V!m?JbnX(VzrJ3y^ab|xAPot;9 zv2v-0J6;a9cRn0@XJf1#kz5OwQexAsZ774>CxzQ4F{!Ru2B$SyFdBKb`(zOha z%9QV_?66qO)`l6MnVkt+sk55{jp)i!Py}WJJ_hH1#NY?{;V%e|r z09IN0<+B56wia&8)p%@?vyh>s38_zlRi$->fZ0IzN=hs$}UC^s`6jT zv6a=k{~(wh*LG&e$FIdp{T^5Km|$jcJV1K;FhTy@sPki-Iq-5>CiW)37J%FG$<#2Q zZ6&`)DZYtlwj3L>d;~UWrv8O~cwHhiHC>YnP%~>b;avn%2%yv9X|1g3#s}rU+3_+R ztWUAip#8K=8@6o@my=FVq5L+OrCWM^S$0J)7+u;3thruMGL<5mjW9b%KW)-($%N<)EHwMZ&xM`R*ES5ele&BUahTSuR*Pj#NR=n`Z zZ5EIN;5AG1puGKi#Pjbp)xFCmzbQB}>&bE4ESh0O5D5FS;U)1uhz{v-LMKrirgl&< zIWl~@bU&Op*~9aLdCUIvTUTH?>(OCoal{t>=x?ReQw?G&oeQnZn= zVrvOiY@Y`0v0w8+f!&h6D|0U?Iy-IE+|>g-Bb`cwWdN$dX61EdAQ>TYjn{RMcYmh} zBt;B5Kq^5%9U3vFj?c{fTufRhNsi=Fs!roGVib!cP*?KS@X3JRrl)qug)gIpy{V0h z;W;s0g=I<8fo-Xf?PPSE&Fy3qA48gyPq-4QB?FIUtXZ7E!eboIDm?vD&=qE33e33J|e zE+VhbKS5aH98Oj9?sw80m}dxAfIWRqMZlB=vX8TsnO(WL@NyO-m;*Vi1C0BuC%cCj z2d9wYqzhiFW%mwp7Vm>j?d03eCk>uYr*?X)rZFav5ih~Q6YO|h&V~R^k0|@BrPygi zsCf6goo4CUhqEy}DFddh(v^)ALzB~D27uLZjA_3v60Ut6tLU}D#e2Z{mlSo7BOhJC zhsQM-MiyHcvtDp=&Qkew8OZ4lG&SQvJ#5HvXhHE9cK8fdq=t(m0nf5X5NGW|jJ_xS z0khCw1&YNKWa<=%NCDxgk&b=Ef6?1fLz7SCWF-npu-d-eZ8vp~Yx;xDcJm?_rwK{w}pi3^wyop4fd0%#=ehc#QbF1zI=?- ze5Y%ZC?_EZU)&I^_e6OdD9dyfM@Rt+j(<$`J)H3gkqNCPxb;)P;H-CQN6>6=m{o2;k(*HX?ODf91cM?bWC(aG zhC5D=(&$%zf~mVG^p9hzyawrp^Jpcd6a-gd5$Izjg>`!UOf3wYmCA7kA&nuyTHC-J z&U;%KLDsP^{wnyNZDKZ)!~v-kSMdQGA5Zy+YSuuxkeu=Cj~M*1DG@_-VXWKwC9aT8 zZMo&AS`E`pskbnBiRI!#d_g4y zi~Kn?UU$DD#}={f3ARe+Tp4-umx^fXOwrfQEu0h6wy5z;=-0=ZSe=u1NXOpbr?c5G zPw-2#-eKKX_{67=pUB3Z_u08tD3(*9@#wky9kBDF#x~dPlnH(rSdc%- z&!2hkcg1iKbYNQfCi_8Z0>xG|Xw9=&<7@2R>veyNH-x=C_6@=Il`p2a{(%X`4Y|zU zf~`#dR8+IcnNuZ`7jS6FPl)x=TFx+LJ>|4iy3@+TxFGTZLW+-C$d2^Q1jQkwi}FHJsT z$C)}l5Y9V=fYQR|jka5|dH67_9x1H)Jo;}W}7p#8&9 z{AM??9W2^d|C#$Coc>cK#L-d^9xa)L`@xvDEe|0iXXj+$js*~L3`i@Ig)OAtq2Cor zN#~~6arr3a*;Wu#V`|?mSV&rdka_@zF8{pR2&aC|zRs!B7gDmH7ew!zE%Y@kfsmV2 z$5qZS^CLK_ktJ;+V-|?S-7AVZuBXx$KP|R_lxg1+FI+=$%|SZ<1$@hj3ON!SWIx6O zN$emKyr#ZX2U{|)faI00#LXehYfy0OiN&@?vKS2`GJ=qE)GSHi@*~RgH$Xwmin0m} zacSTvt-ReLlEus*18Tkst4Aj6valtyY%k)jWWC25v{W z3+bFtg(>S1290nHq?uwaBjsIpeIZprW(0Y{wuZr0WGN~O6g z1t{fH>#84d1ES8cy*V9zd!iO;1#T(G4ufqvU>&xE)1rC^9-a$+5x7YV^cl4lYg(NP z-jg^GJ}}ga@P`q|H(}GmT2{vynASI;@ymc^a)lQ&E*REyby26+6W6_0( zpf7Cme?0m|}~6IvSsY@nDCT>UDp?G(|wd(8xR(0a#;)`MBsY5iF!nC(-aXo;BYk zp}8|j*cn45)q=j)LGqo)zpZZ|6(l%8vwo)k7QB8Objp~1pk?ibE@5k=#^ zxR5P9vEYmvb; z!&}AAvpmqGeDf1c^s?XT4>-fNHnN31Gr%UTfn1jL|U$F|ekrtCeE#)>@{W$u$ z7LmFk8K%i#iT(6nA_w`Y4rFjtal|<+?1kaD#j7dqw#~nty=w$)7EFZU6=S0?{A#4| zdoqVW+1=0Hx@$ZfL^;kDdJAm@yQCsDqA^8{N@fXx*iTVZMsl~GA~||)Rm)};Se9Qx zImY+eX-$|0QwQ5WC0et7w~-j$<=aqA@N?zcXu)#DRG&8@T94M(wDq7XvC8-+MJaA^ zm_0Ijx!eGFA?}AVEaeV{iBYm=|My=+=pR8%69hj8;P^H{bzxZHOtQz)GtuQZju=c! zDhu_XCwLocW%mjftkI*14wuDQjmv1hR)BIszH_9^yX`Vw+AiDK2zNSDOlWu)%u42zWCp^9@%D@%lM^gsT*l_o{9Sr^s?r~z=mTN8X#PN(0q)^h2#U*~EsU(Ro z-CD^-)Vow!(p%L%nJy81@n0sUVWX;^ofcX>s!9-9k`5W+LzdyU<5Y|GLlACV?sflGpulAW`blCmFf=mVs(5{IkmVCmHPyGURM*4_V?O@ha37 zpZON>ld|MAbVjG~Cj2=wk}Li|{kVW>1pDd&Y)#0YYS9Kid0s#MbDepODXdM&i| zjLp?rmsabJugf+!0I<4T+jFXlN!Z#XNU~tUW3fX4KFvNARvXIdKn!e3_403_ z-c`;a2v|WuVFl?AU$b~*IhC5N3X+sEtFm5!e%LxWkuW!6Rv%4*DqU1)ej0=hhOHzo zrE6J=9q~zjOXe3R>B7qud6bRqmK{i%ULF0S7i=SvCT*_WmkM#}F+IUTYcUE62f)&$ z`BSWJ4Ey$qMpCQzcXfeH4X3IO$Vl}tihknQ3J(oR@l!015W&VHhGIR}B<2+S1QT4N zJ+}n?kK>Mdqk)a|wtjz|qylF1Rj=!f$|X&OaTXzw3-58;E5gszPM4Fev_I8l>}FPr zE=Lp*i1oOi=5Lu$s3r*20y9Sq<6e+|Ek)tOaFS0+V&CeGHN zzP9-Jv+~oD=znMf#m^lyJ<8yr0oy>el-8&<;NK!`iys2vOH{yc46TErA1=cUg(@FB zCt*vBN_ggt7)ntVY<+2Zg7P_rljm|<+w+$S5W%amS6!;GN-@VsTQDtw>w^?ARiPK< zp!i3sLS@&Os$l8&N~!|s_wp#@T3Mhk6nmAkjp2*}pCx0$c4}Uetf7D*)woF%sRN*T z^oSq+IqFcCX|^_hPVd3!CanQX1@fEa*~91TS20DiHx~}D{S~tQBe0hxSM(cls4*Hp zkguUofe}Zb#OJi?aNJ(iT^B+VffrC#(2+6xFuq2>>x^cpYn9o(%CsA%_`cgUKy+!H5fKOPYBxVKr&< zK8dYMW3fep-h#?l%U;KvnOTKh3#Q#gqLR7~s#JIZY~2~_slb|}Z!38OhOyRk5pLh;&j$Dcb~2jaie^FNMEwxIGhvr=u25RVhA$GI4bKN?C>kJLwR{hC z%0DRX)SQXA2nv%Xk=z90Qb{yzIZ|e6yk6Ij%Bh^T@8uVo%{7=vfn~Km@Mb0i1_uG8 zH=&`p`-X11od?rzJzbhF>AzTT?yllGEZ@eLc>h7`@Ht!fiBdEO`l1&(Fa;2_6UCz-dA6q(ls-FH3mJIaFxZUgN}%n zhs-0{6fW3|2H$}ATc1Q{p>VVdkpA`X@{!#Sni>_B|4uLp?sIWk!46jb?Age0Ll~0_ zo})%h_Avfo^E)t)sQz?TcYQfA*^B;$_F8ssi4&$;ABid%+&54Jj@dv>+JHWR2^7^V z!!{2yXEwe>;{ugZ>TYG7x3RDX*h|kx)?gYz+Pcgo%&c>U2u#+quso)hImp`|IVhYG zzVy(b*WDtDK?zbfcb&g@ z5*u7}(CA*hC$^)P9vcbpLM9eGevr17cE3ZUO%Hjv8oZxuO?Msix?&84(1*p|nj^fS z)TV5yXh4ClL2npHTj&5k*m7IBzme!GC2yPcq#qpLen9DqM)eKF<5W(eCFZhqryX*{ z$P{Ohs5})1yaF%Ch^QNV+oS!kQXtmtYebe=aRik7*cm$IR7tX zs#)+hE(T!G3Jl=VTcf2}e|FS+r{$`hx;z0Mq0}@4os-Ys%@Em3QL>l^VY9GW^T#xa z;S|?fECt4LJrLBIf&ut1BbooUr6BT;umf$YuuR8Y$er6FO53RQ%!H;`A$91MCk3+M zZaKlWO5;ZYZJ;LoV_p^{7Zv|NLTWU`Vg+hMX(1yi&bmN+K^wfqyZN8EMQ?TOTNHy$ zW9Vnm{h)43@i6wzTUhDOoO7z>xv+RZdGLlzlDBUWfCerM=YJ7RBDWKCJyh86bK}c; z8**Xbx=IyR5T8pE#fRvVx>18{4vv$g3bW=~*3W>Tykm;-`39MY8{z~GbNcY!;@jwW zY^_k&Q&lWC$mB3?0L8oc9gQnBBk6@-jdUm1xH$f3AH3DgIMj;oGe2W|vSm!0+_%rF z)=cp~f(S;gP_ml|B9K%lev;{vJ%-usp}_x9J(28^0#dw%_LyJomm#@+lnnQ6+cHB7 z^4Cp2_%*l?i<5dm;63|c;fZ3dh_5<&4@bs!^sLvthYOLoHk^q^FX}7*6>sQY--I%I z2qNb_JzJbd46-WApN_8lJlb-5usgMhlbll9y^G%^{N|G5-6xiHh#hH9VE)|h6DvOD zhhY;7jHqSmTY76thVB6s1 zfw7Fl510|HF*q(hVk=^8KJr;ao2kZeqHNn{OGGT4&LUN?IjPgt41>9F4zJ-$z)w;~ zdR@2Eqt2s~ysnS)yz^*T$H(Z`IoEwvG`MXHbMC&6vM?1iFZFD1VZ1 z1v_OgU;SZ0t@8lpswv#GV3XM#dOPDZY>*v4oW)iwJ0#_%xcAddp1&gk&G0XydFJtc zT&aJfY{i!Erp~ez-ytXqI@%h+lD1mwQK6W2Dri(%3$SSN2T+&Gl4JAF9DkSmDrTR4 zwQ%uPbIj?KmaV1zPDd+@^=k%qK=f`GypC;R`Q5#o*0;3j(r5$YOe!#(b3wl9!R%RO(?hw#QsB8<*1brzT4k zj+|ahI5}*|;^fAh3-+^A9*UR7Od@a@)vSv_bPgT-R|{4J!JjDnl3_~SYl^*+OYL`g zaO-4>78d66Gzhzo=c}+vx1W+C+1aXZqOPbpu@^^E>gQDY$)ZYKWL^*`M3_cyXmt^n z+jP3^2m1&M6Jt=1K$hjn7CxPn!*8QV4m40A94?^%5e^`gTdx=@-oZ`H>*55x_C#u;ECXBbjI0LYFDL`x6s8B5S0>y?pV%L-Pl@0PTDDlD+D* zj{%pE-xL7Dm#Ci!huSVUTeP=KX<`^@T{d_FoKQx^ouZu$R3hOh?G^!joX#)7-=%@B zFjEDh!kG`N6I6Aop;ct@)a}yUMoui z6qPUZQwEB{LIXG}l6+95mshri#?*oK1>C@COQ(jYsS4P=#5HFew-)*4^xuuomGe3V z;Q5>sS@Ry>htu8#Aodl5{JndvcjfbppHW>2BSFonE}lWvPHx!7civ)K2g{V|h)^3a z<>0Y)o0x=7Rhiy>h_I0+Oi!SBSWhIO!DkqM?H!Ed0gLh^*Oc3Gd?z!*4~ zK>=q~Y-+PDz|IUX{2}BH5U~zui>EBV5tQ#tZl)5&o34}j(Yv3iMx+QWVT9T*R7F%N z7CMX^MRtuK47mp@xznUZ;g+ScioR=`<6dDHL+VmE?^^on2;!h_bZ*9wM5LUqtqJv^ z4xNtwsBUqo0adLg3ZJA}YTLsL&OW6pO&Ks*qx>_*fF%N|0P^6;k|wL71aa-!qw%WN z+RZ78mcR;rL{5n2HCbmwCxLxwVJg&Xrzi$gB&EI z2HFs@Fn>DWShhx7h3LGCyeM#hzZDX@sys(9-(w0rfS9y(_iX#f% zi~?Jl;)S1UIvssdO#A6XJgDk!qNu4XNiJ_ARbiQ(f>{H2C9XIVhfZMmN9es-xRR=D zA{eam?ZAxsz3-n5YN_I=8SGoD|D0Q{R&bU8ixC*Xe^+~{8%W$-xv2G=tbJAV7WxSe zD(;Xrr)kqHR^@{C&B!F0EWKIkJN#r>)N3kx57il4^VY(XAZ><@NpEMYTvOR-CF-iY z`*gBdzVe@Q?PM~>imVIP&jf_|fZ=gPP~vLJ1&<-C!GNF8hLk7a`|zor>>MAg9ZVC7 z0b85QH`oNtQoD9LyEL(X3BI^jHiL7Dkz2=IvyKmNevx_F8p*`}@0P!x4uHS$2)%@xkbAqE3ReRug27=oS3w!@ zdB}xFh3Ak90=6(DURUQ%8@qO`nxZ@!AsR&nUeTkpyt z8={`$_!r-=%YPht7R9B5XOz}Gh5E)$4;bMk1Dd^+EXgb>V-9uzNRf_R=8jOeb3tYD zLXy7gTF!uk+5#pmd}qbSaPz^^*igV$>)BH-4$D|C0cajKh0_QHhO=<31BFMZB1-_L zau@AZusAYx_WN<}lE;x#As>pIMlc_HuQd4j^6JCOL=v<|0 zU>(KT#*e^yz$}4uWT*O@tvwvxK*>kcqakjPlY`XWyD7#bK~vH0SR7t>?bO8@Zqq)z!iX@EmZU6x zwNIe!a8%U-+}VTT%o?WHo^WFLqvO`4xc0Wj@=DR(LlJORNw2l76uv8^{vlo{ya$hA zQ1nkzB`JWQ5P&oY(t87s0LMG2CHO|2!No;)xryd6g>KWxQl2MmH ztN#17Alw^Ft=d#)H3{PJf;Yw*`NbA-Sy)1MB94U?rUiMwpnJu8t}fMy59h}QY;{^m zAA~_0Xhd4R8Uv?U;c5ca8iT`#j}5Fx^)Cn@z&vLqGKPBI(^SyMD!v5Z)M3y_K=4-0 zfg}KM+g4F;jVQBOs{*OZ|M0 z*#qeNz1#qKGQSrM`;=IzZ|+p9(-9B9*d|^OT4#cA!K=_ z1D70%1YV?i9&b}C9CRDf={#+By)M}j4ZxUX>Ug+e$e~NNlmxbvIMcXnB&hCnI<*bsZ( z?2~(0cNl46H(uOc5KtniPSXsO9C6KS3$RuQ6?3L zuQjlex+Z4&cLRR z$r9q@$6iF5Vcu8)*(-Pf#$`Vl3InO^b3}r>~*r7{2{H-sl382;t3eeV`)lIWZI=Jau&7d@%k>LLu>UvV&t5ezrMTXP353!adSQ$ z*vu|2l_T$!A8Kqm;$`Z9z_EL;aHkAp6Z-!31N9`GC+E9UGF0Xn^JEZDFaQju%=CsZ z+)pe)qi43Qn$sir9yV-}DbE8EQQ~@0WEn*-f53<{vFaL{O>`1upRHhZL(448cbp273VX0GPe&sODOD( zSin->Bm_n47*O`S%LPG$3C!vzLP#ShV|#@yms?p)1x7euU8}E+0ZR%YohzrFn%^0* zrF_d0U*Vc72qW%m3Kv45l56azK4l@wRkIcL)mo>Inp#5)nc>3KMmJQ!`Cfrc)qD*3 zV>|8CeoHUd{Gwk7f2-fgk#>Rk!0LGM+~l(ySPaFsnZ@D~vbP4=_;G6Ap%76Q7-gP{ z^SKOCxKwN6(|hF?b2DiKf6_-XC(U5b2yNM!^5kq=yMfD^${n?3L6aq%q@f6%{kb@rb|H1(LG*|o>Qfz3u8e>vGD$A4P1 zv^5H&kz(c1JU{x-l<-4Prw;hE@wccK0p%tesUX(UlV1_=Ta~{AEMfi7n7o0VavBh; zW=T|6KzvL!s1>L-+^B`*&~{^o-&TMnAD~pMHTj-7C=UWqSd7=TdmONMYZ|v*6%s#2 z^~rW(lv3wD>bcEq^gLl!zR7D9lhc~FlHaB~#@jAQIwH2XNHlSqa1lP8DzcR0a%Mkq zFxK0eGEqGAtrJbyY%{*DFh%#h?WbE-gK{(O&?DAQC`zTPd}*_}Ie^VC z3m0wwU$w;&OV1B;Q+_!;O%xqEiH-9>;=zL_yT`VTJvz2K@%wj9_6d$b`@x&V{?l0F z5l!euG?W{{m1rN&hwF$;A8Axe2`|)yF+WZS#q)|eL%ZT^x<%Ma4*CR5`~(W_Dvlk9 z53Z{Zx#5esJs5H#Ey0>s+e7F~|0Hn{t*Vl3>ky#D0B4=tw2O zSbcF}f@96j{okdG$SqM)d59I#L3G8nJW{cPI$_nthCs);#lE+SeS3m#5eJ6rt19@O zMLz*XYEE$8zv|TxZZ`)P?JlX@9*Ut=rhg)e-OCNF#YAG|o3Jpe#W-T5j@J9S0*9;j z^{cr0mwoo^)lZTP$iuHaVxt=rHiqc6MiOdd@cT@^buQH%XZp-^F_?z8GJ-tgyH9YzOVw-9 z%AL>V@j1gAks4l){I=r*U9}QZ@Qs6PB3HlJug2;>U}_fV`jUSM6B;=Z6cR#9Adz#xY6H&b3^FMdbgRsXbKp^aXlpLvBoV*23JEkMiZSMZ-+!MnYJ zuhJVaqv@v>T;&xk^$ITdhb{QAQw#3%3Vz%x_>5Ph+<5vmz3go}koOnZng*U)(-*x0 zdnllhe$lJxFQ?Yje!$lB6b0dO^$ehP1%>p{E-C?(y~4`y507=ov&XEw1`}jB*eq-Z zwlF-cm}bka!s-PxD-|w#%doU<@ey@x3ofdwH$x%0X)v&H@pL{#RqbAdGKW*=N^WVr zdlg@xKv~Pkv$(8sGx<~W6|OA0NrdPxzBTGWA3B}05^PD3lx!bP#D6ms=uTe4XNd=d zh{bT1MV^6TeqeB{(U~?9cb#Vmqfn7_!q*wk} zL*a|e+;uWpqDz-$e*sj(N*T?c?|kcS;K9pFkC}{qY--S$!WUfcmR*&pKATtuZuUb^ z1(uw4xQBJRNL=^xR7)#O4`L1Rk=X5~ZBQDW->Bcvcvy-WTe>%*iy@xmE?cCPNhACFhiC3?H`ar3W9f)sca;zSqcpmMiraAjfgO`|bA$v-_BA8`)Ivh0kG_L~?Hzw&xt;LZREuf+n!X&fv0l$3`Bb=1A? zU^Kuc^37eW+UxN~bsk|2-C8xj=GcI$uh_Xi6mf6L-HLm*e|n~rOu}ukB3N(b0xG8b zT5%V>rGW#BC~6zX_j(8|-<>faa0va9PH@~tSj2t|D}UuFp)Qtvw_GPlG9Z~|`e`w> zCP_F^A@o2@EZA~bCZyt{WNm>@=u4|3-g2$Jo`T2thU#Q;H6ZE3QA~Ufql)wd*Jk+I zc)(AvKx75+u+9)GDTP(%%AbzO=}Yql?$Z9GX-8r^BC(A|o)|V0<$QeQgt7G{gdudo z*x26>E2too5vd#-t~-j-vks{F#5 zyNkR2N(CqltOF@M8$U`}!^99$>v|c4{HR^{!~;}#EP0mz^(=m{-_OYxz@X(6?u;j~ z(#}eBIq?^{*INDx4277b5Ivd@iLv$J;O#Re@yMOLfVfcu z<*T#5j&X+a3*xy>?a!z-(6QuFnx`M(%BGHUn0IY4;gB0>T%08mO{7|=rX>U3!of2jZ_$O%5BEYhjgCRNAJ*0O$Y;TKsv>CYf6|(&JU%g(oUf_d8ye76*iW*VgUjH zO1I{%d7q$}F$Ms_Z0-EpYwt8>AxbhXqD1gUHhvLc!5K`ZnYab469h*CPhL$(P5}mX zyusKj$v<)v-)C*HVBd+8P6OZsND%=g2T%$ac0_ zzH^6}+E85)XEb)mJwadl2Sc6a0YrvBxE_e57zA)L zK20Y}@sAUKa3`1V<9kf$VZh(YPG5Aq;X$YBLGiQVxoePKwg zDun_%f$qKXI#N~<+)g3#J3$L`803lW!%JPkMfJ^Eh|j1Muw6|tbWS27pytq zBO{fF%A0@~nfWZ}ljry9O>uC$58gDS@a9m6BvF+O{aKn~cUT-6-rgUFblye{2?l-9 z2#DD^NZ%!NDl+)wV@=$PPXC~Ng!AO*nRVg$6I78xpdO3@lW<|RvR47MK+8}eQ{RJ0 zpitBuel>6@L@T>Fd(A6!sIrYM$9n3+C;}>_5X8ee##ROnGf76T@W9=JPQ;NM4oBjY zHSF8t!Sk|$Gy5XeUizHko*sIoQ0i1v`e>bm*DN>>^IX&qm5SpR#Lrbf1gajqA`+)! zuv)Bwcb)BFmh+?(eb}?USjiV*pL~aVu`BtAnciAn8Pm>ug`ZBOpw|ZthQY86wI?q_ zh$`VOgg z8x~Hg{tR_28Lt=_ZVvfPZAb&ozZ9BvO~<*t6JR%i7O}1XXs8JXI44F2B`Sjqt9nDn zJAFDx{&90YXonFV!5bs&khtID-yn-*&D&T|kzR@1xz;v88v~ou z^EIr6BddplW4Rw#2h`Q$#}ltkGgU>L;_dNsSxKbV9bGbnh~3VUn;|up{1ZF(61|$m ze&tbClN;sHA+uW%{XS&Q=3z2(Y9EDb&}guWfxTH&+g+s;sOd71tfdbk6i!m#o}X@l zei_wkG3d$T^cbhM@oA}Goq!s19mF1qy*Y0PuD4QabZ^~_@SugaWM3_A;7-1U=r*O` zsFcX1w2)YFpCLFBTqFpZ0pG}24y>r*T}m3qRmHbMP#Jo2#V+96WM4*Qgzl}zo5=kh z->^zO1z_H~$qb^(8w9SSM-#t-+86+QPh(y20Ar%bZ_#8V_Qt#{ZxFigH;B7=z#tyq zbIKsrGZeT6E;FxEy9Uv`+YDlise!dj{TT;Agj{bBH$Z@=83cM-I*^j#t#%C1PR{Ai zAc8mJCZi*1J4F2K%!6;?7t_*U12u2M>+BJC?L>$}NQuj|icKsl-{4T3JWgsr%TPc6 za`lZ-BG5$(P-R&BB)<7YBC3KcY35rw!n)(Pzl`WyoA^Ahh=4-s$7pfktav*v+t!tPZW{7mI>(MNq-WQN9<(qbq+ zCXu*J@TmSlv&@3l6w%`s(>xI7+r3Id3cFSL(Ufh?QEv&(mgwMP;9TB^vP2iXZP8FS zNGO-Udrd=5-BncCJP^QJyIsf6d-+52z+UU#3h@PWPq9+NNQ&!@hMZ{!LxE2(`nX;Q ztdPz0#=zjkA8Q`S##;BPvv`)2DaY!;%>xM**1c-5o=)Ufd>}Jl_Zh~+hqc%6M80Ku zBdPF7uDExG27A#KCDP5T@Pt&KBnEViR&PeQSL2!vf6+a73f?tfQ^PvCOa zPAKj$+i>0bh!f`0%>_4)mI%%sovo41t<+REgPMr2pzyyuPe2H69SH5#Q;-6$;dcI)Q+M9ODPDuqo6D`F-v;%!}*Wt z#=U~F%6|y>9yAX|Z41{Nz=`|iP^?3zLRd}Y>JSZ{Q6WA6Z>ab`p}_bUSp|yI3h_au zf5a@qi`$R?2%103KLN$iWu_J!C28|~I0cGGyo;9B;yltkNl}$ZT*3;2I;5?!crDW6 zHLOpI)3lf^74Ztlb$2ru};FTyG5&^9&RPKxRy_2YLX=VT%s{Fty$d748hiPJ+Fz@(CnA0ri=AN4!@yco9LG zo2bBUC>Ucx=dR>I7>p^G%6I4S#~8tr;(oz8Q}XQF&>3k*N@5!&7#46xkZ){JhV2;^ z(F0$1{0pEy&_SFVE@>ENJ@}*3x*QJTSG00WV&ZJ3sPc&USjXnNe5SJV>c_rR(@xa0 zGGn9*A1SFjx-67`4Mw~pGLHE@GhQC-=u#R=9J!VHaP5#F=!A^>F|2QxuDp`iOd+k8 zGW)%qu+7Sk+3YhUeoGP6Q8`3KQ{rK{MH+TrSuu#t7zEj|mXLinzXdV~wXdYY9<1f3|Lyq zjs&?N-#Do(BC9Uhy+uk3f1e~e8bJU(~ ziiV0+u?9NCwpgJ1A+$L5Of8;vgp>NTXon`uU!w7r<%iHDznPjV9h+w-9DJ~I8bPPT zt!#kVh9bIF6H7UmzT|}ryhNFmT*b27ps35trt)u6L`3rvIGw_BQNd%tNdZ}e#(gQLIZO&eopKbyj4O+ZOK*J#6x8)*$rDga2Pk6;W2K3$WOSyavnTw ziyEd`^`*v)A4r#EJg+#ri za^M4`vMzBRoyhfXXd7*YxFi6s>q`F!$CJm`ZKOSMmMCc;>JwwgUfI{kCA>B|W&hA=YJ zsnd1ow9?7{VePGCA=5(`zoG#%eoGj0Y_s>O*&!c77%7^7DJb{#WPR6Xyenh9xtSpZW9y7PNx^?OlZAfv8WKcKQHi;* z04euu#f{1@4s=!%5=^Zk0}4DrawRo*1TuW)MvA-HRa}gwc8j^6{AJyr4mZU@(VTSY z6%tiur{D~l+V{?-1(-I%PK`=W+mGD=s(hP^p@jGJ<8-Z^mJ$YiSZm)OYFncz8hS(( zOHcbZ+u~B)OHY&K!92j{+_>L9_UaWpF`5sG;)6&n>4baaUGcEmWHw%>hs~G6#G*ad- ziM~>%mx%f=Wn4=2B_g|&`6UoE=J{Ug=^+m2(ohj!;ewC0abbWC8e$UG=LIh_0H?>B(X)hUmVnAOAAZeec6s8|hceo?cc+y?w;bTg|4~G`03W5kLB_&uEAC zX}>QC&ah$1!iEe(g}V$TPLlp#+0us?Edhe(ed)3vA$qzQRvrk!Bg+&G_90HlB+nyC z_8W{h{)w|S!qd`Yj_9%R|4xrz!9PE7$8<|}KO9JVOuR6;SGnV`Mz8UpIWfaHt^apR zpv&d7{sH5`R52Kg1mayX9sn9<53=fGM6g8ehPJ_;IKgUCmei|5&>KSP&+FLSIFtQg zE&Sty_JjZ6lay5Y^IB?hv-fflyB^mtdqHupiv0kZVBUb-8=j?@UwmZp2yqx`oOVru ziv70f@pEa49^7nNoHvBp`_3Y_EF09Ocj?mu5t-VIy0!TatL+!cs0uwGnX8bGvOgp{ z-xi=xRW~o7vBcBYTe|&)iLlt8ZWU*zAKgCmn(F!Q)XhqAtMsE=Gx2}R7D(jZ#ldA! ztPz`%Aw60qE@&R*Ug!uOoI{ngoPeOzQF@tT@eVbbC)-)5nc>(Z!j+}slbg8Y=AbjD zoUOjuH4VUEK}O%aqF3J>BYl&NLn9CW+Sp6kyBahL+37qo2#_%MlaF!v*YQ4mu?Bhu z%04fPmj>y2^v#8)k@1Vvi0C?grq=pmM2{WvM~gnBwJb4zTC;S0r79L(zgN#=cl=qp z7hRusrWQ}jx$^t8*jL!y29ovan>TUSN5uU<(>E^^>pH!B8zuSH^naIcakI!em3sF4 z9qL&Sw$wA%6!`%4d_dW3PTcg0NGK)x&ZKPS?LCErj9KR)kvVd1Oi)Jzp?GM!N83cS zNy&_ROE>qzjdakEk5M*>jRZ}i$N$bq&W^KJrld6L8KxpO@*y4Q#>-fLI#rX{*oj}j zFQNk{<%cFhRn^a_?tbKS2d$1A}?lpY*!_st%4HtbU2~{AcRmX-V&b4{PoBGIG(H z1Woo|XvYA>8a?i@&93C~f3ybPN)>&_zo2*geMxgYYZq*RDLwQ>qlZ4lLrbCfgP29( z{}VlQbc#P)ee|vjf&8@kC|QY|S;|Lb)`#SA|6i^TUm`NH3D1Nq-?ExLZV7rL?H|;P z2o-H&Ql|dR=gb_qli%V8@>Lv963$$G4KvsuRt|_h@|L@H6~gmTSA0!8nLn$9r;@vO zqPG?{swt)$DNp-lvZRl%p$)L?POnYdi8Bd%F$vLw0??4e#Os8bRcA^+Aolk}z2<8O zaBTMYlfOj2vcImB)?osUx#N#K+ZQDC60_S7K=p*WCC$UaAZ2$aX5yKlAVE4irRb#W z)$@Dp)v?ZA_)JQ5@cXRHPYa(4dd7yq8MGhcbR?!Qn`MyHw~=Odz`zKzL0=%jN(7{^ z&7RQtL16t6E@tNHM+PuqH)?f3Cd|$j@OXgUFllT4%XBKG2C5hAsmt-SZ!ZkYyj}=l zOs_nSX1n1|uB9ertdj$>cj-Z%i&Gui^N%wC=UVk6%c!G$xzPvOB6(_GP*~PUf9KK- zyPsk~qihkUfy|GldXRY&0WRiss+K(dFRLVava1bTsG|pG=!(E_dV1ld$fak%qt(u7 zHRM$yAEO}y{cCAVB!q$v5t!D_gdZLxxb&gc50J^z5pR62LM9rYH}lkPRq@Gto-yP5 zAuSuJ)x`bjRsovg-ZoD+sZ-U~X~%fGU4n@C-0`>5K>snGahiME`>-*#p_Lfy{tuLT z%K)+nd1in88DABer%B5o(@Gmp6cF>mJxkWXoTq8nSt;>V2U5c36Otyr+<)7F1yx)UKpd5 z#hSHPd(1xa5ogKpuD=)u$HDB~pTnU`QZbYfW~QL^u=9lm+($FI=sYo?w=O)ZS_d;5 zyi^6jEl??&S;Uv5{DCfY)!r# zoMJXuZzKpfOk$_R%z4InHDjS^9VgMEg&(QTi+B#SP)1)DzuxtuOF;(mQ9{9a5vL0< zKwnbSn@;kSMMENoe9);6 zHyL>0)|7a^!PIF&52Hx~6aj$HBxM-UY79#gCs+_2PWS$0gDf(+|Otr zlLkzUpPy@LJX?Nw1vYZEnNh{FosLVG8LRnxKR-WeAZj2<;P0}GD`|xmaRe_Le+k2; zR!U7?_Xi72CX_t7I$C^l_5fb;aGShHk(;bdW5Cv!{?1qmkHlTlm0*UH>^4ZzRFXIc?j~~oc%k!7= znKNxyV)ow!F3}~EoT=TU-{M#n_EcTjT*Z)6$H1w54Ds#FE+Shy9Ah<33#mOqbBM$m zr}QQ-<=@D%bG9@okmh|3WMP;%k1ok?EJ(1E0_{xVW$fF-HxmkXNj38A{ z6;UJ@IO;6du3N;No*4`r;RKQTT1hPZvi#g&=k^fQhJ5doRMyLP2`;%&15z);zP*t` zxXXc;F7JSPUkbNsC4$})ET-au*iy}vbA%jp#I2Gp7*j;APF zw~%W{4{lXD9C+AO?cewo*w@yl4G{+=iNM@NbJgFILm3u4fQ#RM6RWH(I?fW9McSdd z$D#EP21r<0XpVU25lU`?u%ny@(70tzb>z|X%;8SBhvN|K z^ml>~|B)n2=!>sln{s^SMk|Mw)U`#t_&ntv1DhQm5Fa^k5M#ZK4-K=!?Q&WxpjbvF ziJv}e@(cHHu=(0~aAlG4QeOw-Bg3w>gqgS()^e9r=&Bxlpb!f!r)9^zY{FUsXy$hT z&C!S$F~?|ewom|PUn^S?YZ6gZY#k$;z~ScgdU zoii^hOf5G2IvuyZ0-P`htu(tjX5Izzvb-nqVQ{ADqm0t(IOp@$bR{-o4^jIGwNk^O zIM#1&#-~iZc$)FEPb{W7Q;k4b9P4D8 zJg~!AJ_0y0@O0ylP(1c10U(6}&i%jV1%r~IpDz}OdMCXc3QTZT{2)Cot(GGaajxPc zbBo=(%q~POjWVYtmG6WK51Y&$)D$0RX-sntulOc?#YGZwN{_h3Ca^x?FY#*iu^WM` zOx*Z0)hY=?)w#;pb1WL$&9TutsmL)wMYi}=?OdpTs|dDxu1jDJRG(G^?D1t6Sm;?piVL$ z>6(wsD1m4Fd_fqIN%rOWgD|H1ug2viPJS&KtrZ2-u`OR9prx zCLb`uxJU!Ungl>b@WD(-M+EnsU#6vDi+eHHGhSsyTuMcWTc`2`<27l4laHfAtOSQ? za5LZVX@rZ%xWpS^W7ejjNjLig0#mtSlcRUd0y9WL;7j0w9iiW)(Cv??pcI#rm%Eq% z;Q(@^mpmu*(5xFmA`>HfbA)y)NsK{D%4A87JyW5{@m6l9CV35z?cujU@}R@T@4t?R zg0+b}3Vs>^jAsM7l()gcQBJj|UT|np6d}shX~vF%-t#m%{0Y@xwk{ZZU(`=vXC2w( zcub&i(E<>d*!r<%G!}*Fc!T?)C@jN2_H)BFvNuD?s!mQU& zTw1B~ma+!4zY66MWSw>^Q6MWghkMojZ`2@q*3%LXv^Y}~f0`yV$TG3}2O5(9-lOG> zJ&FX1`{%3_JRbyFp_t)VbK_}Kpdo}|x@IIVes=8n!lu}+z&1{aDe>g}?6fF8Tsjfa z+v&ACmyFbFQ)109BO_bBO)&-KLj4lHl69^-fdpS$Ry2W4ImALsa2U=?^N>}a$i-MjpVVnuB13zWcd{O=^ zDOh=yZoruWbG~@o-mpFKL_(=>OgT%|q9%8+B@@!vr8Epw*_yQ+ok7R+tszR)7^n8A zz{cy$AQ_?kB<*zX;N(*Re*pL&Oy%p3OQv)SrMElNw$q1MDz5NJ=2(7CYvO9-PoUBH zNsG1Q`zS^CJPLA)DRFGB#H5x(uLWkakb4)K8jmafj%k=_ecVukj<0s4)Vh~Lkgt>15%-}6UuaC9j@ zpH1T%r=*dJv#O%}J*Vno{yJ3!{LLm@q8hxdc1t||8I10Y0rZ~uId&2YvO zWTDjiq?aEAS0gxu-@S#^pvvF(-alz|$I3yh zoXeULum1RC_YvoojPn3(BA=iK9CVKDdMMc0_3T;HSkrZu6Ky0rYw}ZkW#Zo@uh6d| zUM4@nFV%m9I9mKW2Pe{kR%+YoT-E5*NMJbyyD_-@?x*~^>P4sKUB1E?=M*H4IJ1sZ z@_;jX6RF&s@4l!vb(~D${VrbYG3D2q`&W-RdCrmvv-BnAJ^S_dpE3l z=#bW$gFff!`lhjpHUJ%uZR_X|ytr=nu7CHgzxJ*_FxUFzA~Q*zzl;|WqUP-aP*x%a ziOvE2mUk@KC5OflRGpM-9UW3OFbnf?R9k$1Oy_JJtkWVU2VxmIk_whAoeBo9lh zuO!SeCDL^rBOrn$|8p_36c9+a}%Mki7Hgq)?Ibz`C*PCtZVB zp7c5AfqGy&q=9(qb?k?xadxIo_+dRRG)7U92}%LJ=kd4Wbwb1jOk^cznhz>~ z5-KuA0lFjP3T^LLvog3E+D_|uF14O!F%kI*1ji@}7jhKU28qQn~ zu=zmwMP^XxhI8&)lt1jcVyA9BC_ZOm#+{Eq9JLN}$<58?<_&u@#N4E(n>T6Z<`?#+ z6Y_CtciNkG%*~_>jraEak`o{ z;9YQa5nm+lFvgYMzP`jmy0^+SRR*xRnP+Y;w>ST0Zl>6dmz$e?_GY@d8E*S}t+`pq z4Qw=-X<7+Un+KEHqZmcZ%?%Y!T~ap_GiKM*kk zI1f{hC~CIT-!nHk+$0}n$U^+FOg@d7&!*3G>Q2%N?w2mgA9W9yq;nZ$Q-9)*mPuX3EUqYJOX3X8`zZ8ba=xZV2Qr zsp!Ovz5k!^YdTZw5vLGKfVqkCDfIakg@it@{K%r#I}9!LZl3q9$-b-0<+~*MFEG4t z9PcK~5)9YyAh>!dZ6;5mv@^XGYPjxEo_D;-ZMnHs)`4Ut&rCPN#pHMp6x*t@%>%$! z+rWbqIB%Th)ct|#JXmVMmVA=;j8l-`pdo6u1a@f&&eP2Br0c5Av16T7;?#YOZ&b#> ze+1u}8^M1_>PGNC;q_^_;C~=>Blr_5&weBLZ%^G!p~Z95ohF`${{W3IF*_C-XK9$f z)|;m<%;|ahdp+H$?mvCuan>-lY=>%D?A1FgTwMLJezboPpKEGDU^!G@7vcNlCDg%4j^*^f#m7Kj@hu<7(Btz_gh0%bury z(bz6ZwOBT@+U#icG*(N&MB)b)AjTNImJdwtqCwjWr|xpv>(|B4>8n3`Ukz4o?&qsu z&BpFzHyh~YbK&ys0?p?&FTMU<#5Yo0qfN#Xmx?&Ebe;~LBhxP!t>9Fzc&x&uZ_WhRQgA)@{`PR4X!Ifj5PAfk^$ueQXQJEh#I|fCVKqu|YdbF6f6bctK{qE|?CX2ru(D^W`q=Zq*bByl63>KU zszQaYf{dd|DodQl?h=ceC}scK`P#!w{YwH(qE zh9VR_m}kEQ{NeP?5;(Q~dk8LM84kRt6FQcZ z5K0=BBoL54BQfH;r!b-~(t8*YhpUOOfl)$?XmXi`WEs(=I#dNCGHku3YXFv(V4!)? zB?c!X@^Teo?O1HHbN@dPWWDlx9$q^(L*Sb@!%OVc8uT?=eipkYoav&bXPZ6qMBSfE z`$ehYW0ZqW!{{=TL*Vbd?U6~>Zcdu*ia9F_8#`Z#iLG>6rsDpV?scr{ffvy$jO7zE z(tGeTvY;+t`)F4u=}C?YT84Kgi}cd`a$rIU!nRz4@IxRpOy6caBnGvOD_9(GCW zkkwA^d;2j!A2;U-+xaD9ZZ0HRM{!wn+0-}&pzm4%h03XnZ~!y$rs zgMv3DeunKc7%yQf`9OWFDb@lp2@^Fd^cw+C4^OuyN(f;YKt<_a@L6lujZY$wQ|vIQ zK?5Tf-6Q&HHSeA2hj7L?ym&#)@$RZ`(4d56@b79@p{t9ee}I2Hl0*};6Jn;+j>lXf z>uU2XF<=A*?pq_m>!W_~J)iTvaIoWV0s4UjvHf zIqevnF-y{7AH@g-%GM@!$ELAu6KCaTDc{{C+nl;~-bE`hP(RC$Gy+-?%nBc_BVMGP z31RnP+g;0&wU@|~rIeLzsa)16Tqh2*MSfI4!6`rM2%*qO@TnKP^-pz2;Rwi&!d4}{ z@nXk|vDNzw=X;esJE%lk2T1KS*tS7fw!3ts79N=wj#m-){Zfualz+}_9yymGLp)RR zM$xusH_!MJ(zB{}K=o^LMJaa$!_guh}g}7J? zDMXd1HY5@1Qc9YvB_9*^h=4Tpu`RH~Y9F}C(# zePqqa+aWl^3NFxob;ucj_8uA@C9y=46bST%kzf4FUC;6Ch#=h;lnz6}qxv(*1 zrJ_0_2_#V;EDM&Z)%lpTg*ArjvcH3iM&h!csHRVa3g1_n>ZkIT@*OqAKjrOd(UITr zNXm%H94g$Z?F_q>1s)W*Q}N(BKJP5Hve-!he)9(79I&wq_h0q^ElS^P!{(uxJR5`O z+aWtoT3IJKy?}_+2t1Odj~_w_sTn`!s{P{`T!UqNV<|z5{a5ryd#R#~sB07IB@X}5 z;N^TfeRV;Q98leEl6x`5QNWB&)8v*7^pQ<7%UP~fvrrbcmMqokRd(rz1W{<m`A>`Q$!aGCD0Uf9>Lm;b61x0XnpXKrlcZy zu1qyp564gO5AT^>^+1mxa3403Y^P|j^OfXYr0gSRaCH`9#EyA+IRa31sG=CI5yK1G{Mk_RlV%m*lmxS*Y;KQ8ziX5AQ7y2+gJU0+wV}|w)~KD|4c?> zmu!~vBB_}UrXelaXc+xcdY^V}?Doe`bll$u{(#>*Tw#}+Oez0`0&E1fD^BMEXWC$t zJ4UIMLObugiy+|_`RSQapTt^<5;JfmOHFUZEsz_XxFQX=v66LE0)k*GF~>F+us^)w zYMR%{hUJFM!Bk6P2jMtE1jE!G#C=38ghsn;+kGx#AhT}*_;Q#5zG10y$XA^eawlik zF}*}t*FNh4g||=VLE>Dqw_BT^2fScQ;vJA}sp(_0Q_`$HCY9R9@Bx^D^suFrin^13 zK?M-~XfuVA3%DbwG93;Twp0BvK*!gM>=_Yl1aNj5*J}TjDGTHBb)=}8qRS^BRbvfPTli#JJmpg$-eg-wd+Z4NhJx5nUkJv zt=T#-E5ekr;^nssNzMgho8;3XMv=!6y>Oh!628M?jqtol;B9+J>;zsDz4*_l0}PK% zbhgeDe+Wp}ouk9)d0<#*PnVl>o?Kbs{JP)X6%6cI{JfmTnHO!cp(M$zBC$PJ|-a}uFK zeDk8`_~bntAD55Nn(l@gyTT8GM^asb?v3!+tj#I3Vm^&Vn@V!caeKtV1BUD2B-GeN zpFK|MYb}*nlJhAjMl7hrC%0NQZ_TAW_QTW{&1o__*}_@9DEt9(lCXV=t7KD=H&JKey9_lzgOwW zb+il;&$l=#2oxl0U$fnS&gS-6q>XK3P5y|m6?0NAwkmG4s2vvwP6jycjZAX#UCBQ; zG?N4%C@sW2aI>e;EG=OS8Q!LGOWOYSKEYvf6BkHihKaIO66;C~pa+P$*FOc zQ}u2-1bi9OZIjY<(A1!h|drnMWJBfn&QCQ&hmSNd9D>SQo`9J z?GViy9HCdG@RR(i5|V>*oiBC|o3R2f>aI45Uq_Z1r$Cg)0yXv;Kjy|ZyZ3Y#?v7Tz z#L`8TftV#2KLU-!fzU2f8p|Yo=VxWWN}zBrF`RLx7VG08KFlooUYzF6%GJTnDz|Ke zPiex9f<**;*cwi4WjnfN^7m*L2NCpRvu<;)o*5pSR;U8%i_!R{MFFWp~AhS+4NXJjkG|G{c52^D_k=P02Np0vX zj@YX_uP3SCI5Jm*4$?XPIzVfV?MCfT(5PO`Bk=s<8~WuEWH}fD<4VaaNQN+E7}#Gi@_0?I$NF zpC>oZ+`z+E0Xh^}#?_)y0hWdUw)KLT-`Ick_u5jbw2m$2XE61ARBAGqwemY3#@J zfl=%ii+f0gdE;0WoEuw?RDtru`ehm=>$SKifk(Jm18=!Cuyx6uH3aeVF|bTlV_5)l zzKJ6L2P1+;G412><7X%DMhEDz-}K85_!SBodzHiu;-5M2FwqC_e5041W0>@M7GSA|BuiXAq%5!*V&&AGt1za66o zq`@+d)#HDE59C2;PyBind1dkz?r%&Xkqic5ahkJP&8^fMgImJRQZ3ucc!X57i?xJX zPH&zvNtwX0xzJOo95sc1em84OV5@WgT)-WUkIDy9mFtDvRzN|yEmRf1!1fzLC5M?5 z#*79Y7aq2c4ZOfxotoMziCv`FFyn?seB0(_ktlNyieS~dX*Ws>e0HHg8SA`pCRr-V z=!}mOn8!@-5%adgDI;(qlx4VKsVF14mU&P4&7|^EY_=PQ=1|ERta01T@{J8cG_LV6 znqtbKGu&^Zv8?=Hb1?%z3q1itM0~*;YccGyx5xh7JuE^orH!kzo>fSPU?3;oSuU9^ z?3o)F>A0_Rqgu3@dNz}rl>MwYjo#S}Jm_Rp7}b4LifLBSkHmVK1n{1pQ}CAHtxdi9 zovLI4?0y>dv)=tT*b1`&G{@K9O)b|@i!uvlY0Xv47riAZGLs@w5HIXo>S9W%elA|N z?a%Ye+N1OwZOHCOCY1-md(Kv-G(=fn1SFFof^DOTlrS4g+XNJ&z+^v0qb73F0a&(man3#k@kL(v0P|6+tYc629JASpfpZu2Ywcya&z`I~M zVShNW_C^CkOiT)FXd-Sdu$A1Vj|8Q!+e&_>`;0SGv&2@@$L-8a2kTi4iT=OA*L~W^ zF?9|U-UB;}Qp@C7? z*3bK zlsiv)+sZOC9!RuNQrF!)_p-Mim{0ch{^M1?^(9lom1othUvdrEW2>%3Hy_)kW9VP6 zwhMO@iOxexIVkvGT{(vbCf!rn20Zs0*c7Nv;+O@|iO>Ki{DtnM=stm9G@{IGDb(EQ^Yj}AR=iAG+^0cw0 zdqCA#JwZ^Xo(!zISWj|$pQKl1>q#C@yuRTqiJ3SJBjB@ibFk({RCO(3pv65W2 z1y{~9$QCLZh>2vga($5KwzWsT5@+>X{!R6he3nBK{?8qx?(O{B#J8MS7~aP3J@l}h zdrsi%m~uI%^oOtK%DHA8wjTbHp7F0K9B8cmeUsn=3{8iOWyI@}@j5)s{5UI~@L;9W z|Hpxq6E||Qa%|9W^+@Fqom#6!ZA_~>diU8ulF1`4b!Hq}bWCS>%>F}Rv-9M!5Xq=Z zD%Y3bRZhfm3>%zVHCq4mZdS`QH{H6(rsfkvy+5oxn-SkZ&Rw)Hiil1hM7qMhV}aJ{ zSCkq(B)^_J;DAjlL80n+Y+cQp1FOQOPrs&5!0j?X(V}>@W3>Iw6D1O^0Ep$A(Yi8g z-XBnv%hW|TbVb}rv|?JCu9l{E)pQM9a$C4^Gg>6y)fXNVGBzXzM0_pC$XEm0;H)Wm zm@#K1O+^Rz`I}>+QKtY9`2525^d{=Gn>(KJ7Qb6{=tdEr1y^_r$8BQug! zjKszPO>UE})k`sRR>nU|+Omb=%5x)?X_iY65VY#+b!~!r7f{ECoYMrRqPluLJjTNo z#oNUU0Nj;+nV_=(dYue@94uRJ3VZTf@Gk12G+7-P{I!62UEo-C0-RY2+|p84>@d|2 zg)2$U(se`ZJqYaw`H}Aj8@ddo`HnXnA3&nikej|;9|a3rL!5Hije8+??#=LpoqTd> zuL$;_NuY{z&QkPopnxRt%_N!umV>9Ii*PJ3J(_H8LCY*9pG zx@qPgh@a2De;1w157#u$=Vsm?`EzHzGxXM#{8$L={hw=hhJNWWe*F7EXXw}d=nTD! z*Y~zkL@y4Kle+ppL$S7+*WPDCybwL3t!i?#vc9H%5DUe%>V{%IO&Y~%YA4%)8f%V zUDIMwUl;k8N&u9vK3dpR(+<{U-g!P(IDK)ffmzL*79Vx?^w_Agf`R%w->&H%wB%=~ z%7x9bi-Hy#2) zh{cZ}DJQ<%_N6&<=2-kVehH}I=6pX`*aoPb+9kpeu-K{HOSb{$5dM8i4ToZ_TN6;t zX4UNRH26IwSK5-(1pB-BQ?aFQ5%IU~bZ5nvDFujP$N#=*B_$pr)Mv^ypiWv9LpOc9KNgj5_lVmZ4g#Z`o53t$PHC9z+2b{cFtHeN^9 zsn)2D)0H=v$QNciUtlKBqqS$G)(b~b-|oBvOkl-eEGJz6UY5Dp!eun~R31AtD}#tS zwkpXI|7;Yc#W)$t*+_dZ81>jcUTqRr%hX$Lit&`qhSla|ZTz#`VQ216#PMJ=^%+Tq zibFs4f0cg3)+D~hJ4jUdGHV|<-N9B7ij%N>n{@5EiPVeN(c8Szf5v8IHeM$5t1*O{ z#nN+p3Dt%eNl{`16)UP{kyZ?5m*ye9KkY}AJs-VFgf+GL5fnMEReq%+z25X0L1Hm&^y^q{j4^6pj9U@t7u@EJlDe10sarco zUeeNK!%SHVVFON_E<>@c&a@2y$8j@yp=H)*m-cB`-L{aUjk_QA-bhl1u{a9AsU_Pp zz#}n2Vc_puBNXYiDKvRsrSr6-#dNb5q6~QRSIipB%s`)}ZL^6QT>biuylw)R+*<*- zlA6a>Dzfu9?E@bvYoJ#-!%a(0hV;Dq4BcPJy$l|>RUS*BsDaO-FQ$+k2n3z!+X5pO z|GW2Pw!S=artSoLy7PBVH*3!Ck({z~mclV+FFColZ)d5-pK@>92>!$mefMjw^7YGo zme=4EF*549ao01!RoKw*f803Gpas6}D6Iurm$p(xiKUE|0)+D!ojvzUBs3j_ry^AZ@{F=byc zhwT56C6~J^263v}dk*7NjwwHUli=r54n_jot2-iB#i(y{psV^f$tPKeX_sL2NBIGjsNNi`&y+PIlHgL+e zXNEi5ieoJblx$Ch0;^DLlbXxaC&WqESo6mFq1ZStr^7~^Qa;bCTGMlVm&)Se+bXZ0)QA(NmF76`NFL$1^?rPu=Wz*b_4a zP073X$N*fTA`)v8ptWU!e4uuAF1Ba7bGw0f1id%~!iYdf3@0s6>~1*mbqw?vj6W!w zq&tiJXPvE4chp)y1X#TFCuUl(^2MHe;92z*He1ie0!rUFOs;%r6$*yR>Dpu0gzX?Lv^{z#CVU!(%EuThT^|tKN}AiZWg+kbS89=SQfwEay9(f?a|+ZTH}{i2 zS1GpZ31$hWUG(wYNb@>orn{zvb<7NX@>z5VJW7a&k;_7H{HPCSWV=GOt|yVt|{um|$j zP}UQ?(58U1B2N|;NOqY%X0-nQk}!`lf(N-qni~b4U~CH*)}{B15kr&wD!7@gT`G0D zW>J3WfWyTQ<=KZrPQ?q(w-3Tt^xy&&`4vUx6gveQ#vJz5xIXxJ3r9G{aISpR;+i11`qN?YoQ!`ts3+6 zv{g@7p|^(v$E$xC3fS1yPVG~4hTY_PF5$`z#OOGu#7#d-Szz+OldR{pd`ib-4SO`Y zw>ZZ0`XkgPl$039&_Th#rbS=Fa8lDaKp(3T`)iBs5 znIG|OC=MKR?*B5ot$bn)jX z!fj7z;uZN-d2-~>I&@@MEkj2ltt%C{jHIJ7vXAY6VpF^2(+ zA|;Q8F=6=d1gGviWMy&*8m!^69lv$zhVn!^10qmGGI}e7NZiPcQ`i%0$Q}n^4sXlP zOB|hrZ7`nk*;|d$z!T{j4AmA2fw}sck=oDagq=IOlFz}?EEqnHDs{b^^Ktw!z&tS| zFt=izcF)4tggP{0A^}m}jGC|~VX*=l(5P8E;rsJd-a^LWKE<)UCGO%bs5}oU4{m)2 zEk%q8Y9r#p+a%Ug{&Vpr_T*q}4;VQsrU1_{{FIs}-+7D3cCE-(%%GkD@cL7{x{R=2 zhC_zs5@tM*(~ZB-vo#ji9@hgQtmLIjkTP#0{8h&(biXX*zVfm4ckO*z5@TvTz)DU*R?uX|XX9j7$ z^CLFugnXod45$q6k?tc77TYSGQ`!YTnms^N1SgtFjd}_O*)0QcoPL}r>gEi>uH4Is zjQvb}2&|5t3nN+wX83RVAS1eoiSN&duCSO`F2*oqbsmj%*z}7hPreQPpq-7aNAZk>DqW1S33rEevU!7}AIy zhIElsmkDfflZ-X&qaksYx!OaH_>Kev>z(_RZ(6PxOBtY6nDbLk4LVm*qzz5?9z?(n zn9pGiI^1hvq@U>+yv1DxVgC%=d9Z0y5#4p#3e4m6AHr018o zvoeV3bMSO*hpB?^><9+7F0O^=WWsZ9=P(1mEXzSU6u@@!oVrhl?F=SPtz|pEaq2Gf z*iJp2G;BxMD3KR}99qoPVy9EcW*1cdyZog*H9W|lxU<~wpyxj4@gP`;$AeUeLGz6` zk#=>1SXCXh#`FphLnQO>G%>5A-1JqOL8p3oOCKz`VueA$~ifM zIW%Vnl278TW1o#JAobkZ12w++8Xr*?oZ34Wm4Gvq5;87M z;c6D@;2!2WfA*E-hEe+$=2V|6U4~8MG|RC9~ua#6_A;> zZWSsf4;r2CZaG`p?Rx&Qi#Lkpg2<4?QI3&{2?xJ6bqBcHy$Wxvqx}m9JGI4N_{wPI zZTbFHKur_TZ+u^bFeP{LO6vA;u%sQ@@{U3H6FcyAi=xovr3Sl}J_=p}wFVuEXW9kq zNcyTl>@vIpwi1eeK_f#b)f&VL#S3HuS@8@7WWZce%vwLZhBz|@5z01UosJW;2vbAJ=`Pt=%@d=*SoA`y(P;vZs^K1Os^Ck z6RA9D*B@RqMafu_+KauEG7Kq%uELw~9I3D63Kmwj<0l#2!TFB{RurmeL8P+F`C)ye zb2kyc%wpt{2CZgU{#@0yO!}sv7@=l2%c>o)$6cn&+5%!dr0|7|HV=ISrxtV-ySNC& zUc_Zd`&uf3((z)=t0%+&@GM*(@-;}bWYXi1kABqVFQv*L9!mQCEBkvu)V$@v6FiV3 z4?q9NPkmWaKQKrLDC<$GIK}n6C~>o{l2aV$u-u%KEODo@Q)1chbT`Vj36guMS3o+C za4J0AE!#=4CyXz&*1hu4^0h3=zG>+=%sPttAd7a{vI=f|GMB1Un^sLy<8s zjB}8LN7w@x0yQA;K8{p)r+Do8UU6!djwosv<||$&-Thd-Q@1z~%5Q+m%YD84XpZ)X zveR@a%a*diW=F+Z{;{V!A`9ymc6C}xLjxL-4wY%yHHrrgQjv8 zH4N1U6Q}|M!iXFh(7Na+G4RT_s!a4OKWW?PhTab&9NtKoWr&E4{$y$lIwR9LP>JK& zt4`f4@I1t!j7+Cio+MHj@Y1njRqZ%hxGdEhR6bT{Q6C%4{`BXgvGsC#7{fC{0_s_g zR&V7}xXlK-I*m{B!v+%;EmSo^1gepRUL3%#*=$t`vZorT4Rx!yw-$oWnOfTUV9_|f z7CO}HYbrFe>QleQ(V?yC2VGE~%t~;x`TzrfCfS2#F{ky->?jtd`Nh7(b#7S(3kU}(zK_d0ANkSj4JQQ)SfTvrFC~jo`G+L!Vn4p)_ z+);0EVL_PFM28LIplmCT@Cr2BF)}KpA5jg4Mm=&5H@rU3_&+cQQ@hxad>>QpH7F34<$n^2aq6z*FG6O;<+2h}uvv(nydH4q?;X z^yZLzD;wF9EJP6`xkkKU-`Fk~gF%MNOD04sJ+oaDvz<3NNE5M1i1u~jny%F+b5_bq zv*G{^vUWQgH$*6DgXec5B%GpZbtZZxxNY}?j%I2qQ>P0mYN8hUn_ENGT_9-1{&2JUd+ zaP|IJL(Qx2Pr<$#XmM(PDX>&FMgRz%@n$~xJ)R1HLMyg0;qXNNmqp_GwcQ8&67CjF*PL-VT0UC=FP z@G}nwaWmO^UK(qzd5b6ntc7ChxW{7ZYj|e>zsijqgC>huj^+(uM*QOffaZwv?bXbz z?gM7^Dt2BHJMOXX_gLfv#)9Sr?8U;f9oa`&eue^eJvtFSYAjs-nXEMp(}ttMps8g#aEp!Unl5YMwPKvtc7aPJzTG9h_Q1|1%acFW zzS{ra-n+*~SzQbN&&))K5NDDaHLYl;N^7DR69gnmH4`Rb1||@>C@2y_5=b;8F_|cO ztmc%2lENTw?b~vCdMxefYi&<2^qgMk>1hq3fVVbil_*}~t!6|^v!Z|CRo2mwp>o*kdi~8&fkC&8!j4CSk0?d_KQTy%m5(Dg+rm9?T+53zWgFU zd^lRdzJieb0=6}=p*rRWV|l`xLB8p{KdRZ%i&?O`BzZ>LI0fi;fsx>p(UCI~wWh{cn&~1V-`xsd<8{5x}I2^r^T!Kt2ceHRR z0)&8H#F&{Re6~3M%VOWB$x#@tRtS}Ic)dSV_Ey*9(Qm@` zMPaC0UVjWJ_Z4Y!WH##qy_3ONNx2oNKxA`nWxkL8lAQj&`=jSGvj*!&^o$0RTN(W| zx&di%nTn(OzeV>lU`dO4S!XGKP0EB~{TqQzR|xuTrCio9vk2&&IaFL<*c)57Y}1V1 zBkRt^$sy-LmfNBoUmxi`*ma#`VfADknke%K49gmufOa;&t|co?u~_i*?T1XbHI!-*I`Jx_!-Zp zAmu3KM(@EpCi){)F$~&vV?v}DfS;H8D0^?eyqzO&`zwp~qU9p3BUC>mq7#bm{rE?( z?)$SgjiVd;k156O`$6`?WERQp8{Pl9u%BHoWvMfOi&?(Czy4td?AG?qI<2mr722^&A3!Wvpg1nHS&B%J~JxYqwIVT~CXJiFid7 z4BZqmb>zQ-xG}=+9N!dR^Aq?1f(gt$xE?^aUBS}e92A2PnantkAz`q={b1KKm*K4` z+!Lr@Jb8+UpM_N7-w%q9KyR{dLNTbig~)9FiJL&0cH(%+X{^5iGhg5F{fF?aEwB@& z%zA7;0E96c?xm;u>d30>L#NSBG|ttIr|C9EX&9RzAxpP?cDIM(-R@@arL%Cici4@h z%W*!PC+uw+C)ZT(#2z!}3@z$BA$+UV!<0e$HbUc4~FQ}(+gJ*7rhxl8ut zDdxhFO7U!a`}CQ_i;1d$TeYM#0Uw?b>ZJ`Ugo9DhGVD?1t4B+pLmz})wRi#fpVE6; z^(d`^?=OakFOqEgZ@!O=FjC35^yx#7Z4IKBzZ5|-TqZE z&sHXaar10BY6VvG;0lIC;U2UcRIqP94jBAUuRmQLIN+Gj3MszT>9%;5Tr3s?W zUFn5#u>ickh6gdu&aD~YuYCt?llHyH4=VxjEWhk6Pu}&Ip{~LVRqRt2Vw&2qLq`1H zG45wBjpTPb_WOmt#J8GgQ6gE=3uUt>V3ZqWvnLPP@`gVJV7bXvHha8UCgys1@|0Iz z05;0J##pGHvlT#JhR=z*6tj?i+(AE<9q{B`ovXY+>WNugx24jL(2kgJ2I?;jvdU7_ z2BQmi^~S{f7zZdn+v|f(XvV9JP%;rA&M{sCZxxxw(~4#`*0 zRGb~-kJKov`HF%Ehp}cUn_*?g%Bo)MMX_xvFYOmu*XDouu%O(~c%Yr@A1^!Txs#OG z*I=o2M~mf!&*fWucx*hor{i-yc`f55O52b7Ey1*s5Jn{bK|O*lv&tRsvoP@Vyr$3v zJ9|u998Uo+>70h9bWZMo03hYYfI)RW56hYq00^>Z{7$o9z*pPRrSC3RE+Ms_$VKcJ zY!n!5`u5}@Lfb+U&51c`eWolLiR7adL`>efh5kme%H$fbw29a7mD%L;q}EWB zNK6~9Ck3`!!>>P*+ze085@3>)Q0#Z&rIt&(e={b-i_#~6xJkTyY+R&3iV{nIpx}L8 zvivMmVzX_OC}YCWS~1!bZ^6=WHK#fiZ|LSN1yV#xGidU^S4fj}Ys~OWp)rYMdU(Ed zxfveMn3rOEdo5+i5ZS{v{QAQw{qHRYspTaNv!b%ospu$C2W6a38FKXKXJfJ+FvZ#g3dT}?V^fOwu1`b1WlRxYHo0U&D*CpPF}k@`FcSGT`aE%>Oc~+=MuB z-)F0bo&&s;S>=y};^!&*H>85s9)3uB&w2}oBE~CXp)7;@)!SmXXH$ifE|J44no>Rf zAcqZXO&YyNFg;{dJ^g$d&nF>7JVi!*FnE*?4K+;midVrh${GIVL&+djLy3Q9pdu3K zCe!HR>Cbtq}VoUx6xi9lR{J`x80t~3uG_a;47 zdm^lNuqx>f*p?Bv_h4fp%gLsr?0#_gPzF+(Ix`q4S0XikVw=}Ds^yw-2qL>YU;Un2 z6p!ELUzvbTB%8E+rYPAYX7HPT^Z^Mv_*x_`1Ye1%s&{4Oy&^EOIflr zZqNUep2d!M?i89WBHz*nQP!iHWp|##B}0A3uq;{snuDEj4wBq<602CH@XzY!+z~r? z%G?QypSF#q9xW%8tjX9j|G7z)55uUa>cU zID)mk{R(+DS)QI_P=sIjDkE7UT8*C1!!rbZUScIHoW5Vi86_fYAHQtOFy{(V`8Qn< zs2>!|n4^R0J8_egBO;VSPx<@a6uiL5WN`nROtANTeVUidgOn@Q)TM8W5|| zLV5P`JTG$F0n9UveILgdeR#d%9SZ#cGVTQ_m4^Y_;?Ixzo&^te>{cIs%j%Z|STqic zDg$mLcl#XNwa{4bR28ri{1l~j6DaWj=Dp#Q6+$wIsCC}FeX%xH>H%X(Fv#(~FM{VH zJRVGz$8#}rQT9tuc=BqD{ZbiPR?L=J(zU1-E6px4ex9{{)@1xFoJyI2O$;*NT*+Dt zGfnm_)?+J#&a4DI=AOBctW)K!w;HwZA$-u>k2&d)5Z`_5`2ph)$5(~{b6&N%D{Bk7 z@#gIq$7M}J2s<5&#p~a$5F10d=*nhYTgB!mO4UM#XTxROO1~g>Z5nb=>8rti*@McR zf>g8Y3Gn|(gcoHjj8FWoA-{ADPtzbS=GUfKg5XHBtm%Y0^DJp*?V>h-Bo_XIBxAF&$ZSC(7@n-a z6%v6dgMp*+?YF(bzUP9wUPTleQFt21U|7Aj7h^DRwAan}FuFilZ^~{0V$wujl`HO* z^$xzTVGEvRm1+&NWjyBmkrgqPIi8*w-1j|G+Q0vGQDkftaWbEkU@jX*8qJj(FFV4Y7DZh?Mn#Gx}HkF6t6n!Mv<@0_*?6X2)ZJ3sCci9EYPf zFieK*F)Hx%48fNLwr{AN1x@u#7u9|5Flpxsucw!1RbHaP3l#8JN~y0N3ENl0>4ng| z0=LMt6~Y!GEhB)@jDDfsG-s$WdCCTeM=@oBSm#GtZes5lei4k!AvrV+eL@#Po)6;l zgii>QiJtgR67|Gx&sXOHD^IVV|Mk)~UW=)@*VA*6YW#9RH%hL?Pm;DTisa*mW71(m zPen%|sQ}vUo(Jfb=EKSKBos<@59*UMw?7gpdnyo_uk?aG&$l6~DAd(onY{}dJ?iP% zz?8}KDTYNIBF&XGzzbp;xDQ4B z%WN-QB_y;>5t(i)pC9E|r%>BoRHUpSm&(eAuT{M6>D9Ivas;P-z#nPC!|aG6Az`?nEsi|Y_GQ1IF;hHVe4ddpzj8W~fqa=t z#%3mKSVc*^xnN#o`3s7dmjw7`7^HH4DghlcQOviwwvbS6bK!tJ+%-ZU;x((lbLXi> zIw%i{?=S2dLVYi=8G9sf0c6Ed&LPINz|ZG=flJX5^|9V5yMjW!v@QGZ9$$`4JbwEl zGPr@u#6E%vRTyWm4EHWcBRmszsv6;oxT)-8?LTIOmHne0-&ywf9vC~m18RI<$~3-% zA2Po5T2n)R_!L2HQ~}x~R@1{H$ikl92l@A{f0H={a;z@;tFbYJ)hWMbYF6w0x`-6n z=+HGM9c33mW^*WAuk#fm0LuayFF07!ri=Z3Ig=4Hjw{Jf+mZ^jy=Ziy?OcCkwM?*u zvQ;4QC5)>=ikZTivym6o_=<=szWlfBM_yIrDOGWVMV%)Q34~J}lR(5|ma6%ti_f$O z*PL?<7k>VteM(CC2Z{+s7AbR~u&=W3;nIhY?nJ6na+T1VC}L-+og-0*B(u*@*?#P+ z`yOI9*0IlD_KJ=pk(8}d-3g?5k^@^aA?c0xAM4&2=%0|^K zX5k9S*@_TwBjfDTG7j#!_JLW%tqjx;+hhha)xyqF&EI4~1Z^K+0#XKQ`-I4u0l}nY zS%X0I_G-P8wVpYbgfQ>?Sw`wn@&N~E(#Sgyjh1&-@-ZsG0E(ll$UAg%Q`ThI@=Q<9 zHt~Wjl}T@~@HtW)xdHb9!j!YlmTrpSXvqc0MGg>PIif>k(r&)7dzJ-<-FxU%BW?sl z3i>V$*Xs*g{&|r)k$)b#od)=)pm0e}n^eNm*580lK z3qVS7qYg-&DF1}YhD83MtDc??;mnR`2Kh%C7?*#_r6(K@5b2e>0^!NI2tUyqAwfZ$ zFCW&l7pNCCO0KNY+Ef&*SY}?C_2Ix zbkK1~Y%jzCyU>pRF@US&(r0a|p!ZD*FCZRX_Z|%AO3G7-lSwUa@naTAaw9$*5Z`f6 z(IcYITc9>ne0|TzNX3_JIS;F4+vA$wo+0z;lssEr6@IHsErMl_cfHW}42KihD+Oh0 z)N~3$vk0NL`AR;@>W3j<6Q1Xc%4*DRtF#kjY+_X~!EoAT<)Td-7yTlH9`8Tt)W=gx zc;z3=)+;zB;Y|wXS-VYS-4*@LoAx?S5(pa(kU&hOXF?g}>_-SYzJ*j$9t>5$k@XJP zac9VgG9@}E_TS_TI-X^-N)c7>*O2`iY5;Iv?Q3r|jJStI2^C;ggWBgOPGFjz+ZTRpn z6^HMgPBzJa?#_z-jtq$bWU$pI$Wrp3Z|eUU`E}RW4w3Gz)A;!V3IZv8zoR^>(o-1? z^d3}tMS$yPU<)|mJeX4AAmco|lH!7W&npAUUhIvr?)V}Dnv(GMg?iAZk=7(s6?=LX zQt2jb_I9@t-I$&ffVVj45#~53lsK5ui62klEV+IxbtCy|8e$^A*!*WS*3Qk8+@EK_usJFmnAdeWVg?2#Hp(nB2n({?MnDT&K3{ z->Y^!!PYfj*6EQinn|reSsFf!Qt)}4+A5OK;{|`hVGh$N?2py(Qn5kGt6&f6{jyzm zyd=t>pGbE0RFL>w{IR`q=v(T{_k2cAIrNLaqHEEaC*V!rVGaAp^jppY+He2ISO`jU zlw2LC$5*W^Bzm4f%JN69iQyo|^Rq|%j;Kh+KZm`B>R$@>JuUwAa{Knu70i(pC^56E zkFuP4LU|>YBS;qx6FgXZ1o>v|K7erd##ZBmFuxL+k z{a>=<{8Bm{`XgV0?hmVjmU!ypvt0Ku*1^c6KcLo2@OQCDSjM^PVFcip0pUJ4#;`z& z{GwIB6fh)4s!tyJQ3AhJe>Yu$hZfPxhEe)(P?zK5T75k$Ok4{`J16P!I!W=vo(+)+NvICJO`Ifht zcNdt^n2qx0kK%*NhYy4+{C&^Qiy$?LJnk=g3daZVVGfw-1)w>PE>6ohk3J&j(Q$lL z&3D)xf8>NGc13bBn<)&Tj&=ey;Sv#lfs!5aSzAEKvWzY4%TJufhS z)6xYtalR;H)%UuQ1N@>Ef8C}`+16CM!%vqD+%_bm@gHQJqX<*vv^mEPeJ?Sdm3;?6 z|G&|di|np+P???^vPB@Rm%71nF%*G6%~Gl=&5?viJiSNxUoXxQ%1EgQ9U0|J&3E~N zQVD*-U_jHJsAiR^_9+fcO4N_60pg>oe;!|-n~x$~NL~H|$NC2PI1-?2hYkV*j{o9c zc30nndPAZdRL4V&2(=DqxPG!7lfy7ITVb=y#TRN5XsZC3{GVl1zHQ0=h42X=!?{Q@n0$Mk|m(h-;R&I z2}f7R{RKKC$1xzv8(`H}v&`Nt_M8fcY~^aBNqmq_7M8-eGgK7{e`TRw#isu*N2T!R z3uWCUNA1eE!AMDZ{3hB|dfN^BMSjX>$0c``V6rk?pcip9X9(5vbL0{$CXV2oV)@FB zIlc%a*pB+>3L``y;kSUg|R=)ZV)FEWr-GDO&6hHQ5bAlgn?eLp3ep?QW_F% zS1yjFwqe|FrYo3<<86rdsY7R(_Ms}%obPGz$58f`=gxD5aWG0*d(ALEE4Ye!VVOff z%zE_^Vdk$K5oZ2OpznF*RMO_-Anjl0MM5tOqfI~yeM!Gkd{hh0`1nMEwri2^NcFrxGb;OD)$lwj3Ti;A^o&{H4Z3`q4LtWej#7V5 zKYz=BY9U)^oI{ZlCRoJ~J}eM^1hvZgA&2kC0}cb+aRS_|r~ntU8Pbt9FPIxB!cO=A zOFuNoPm(Em74U^?2iG5Rpn@*iO}4z87ox-OBLA=vIYfvj6@^H2c4`2h4)i~86y1w# zaiUbOhNC-1ShLT-qWJ;l`^&ZO6eTd<7Gt>Y{LyE(>0yx~gyo&ZkuoImm&ey|d1-2o~u#X^`c+tVLHxinx zR$K%STeeW2Ij*Q*@ZfBZ0A(~wvJTv7&Y3}9-Tc~(+wKg>{oSe@&6P8o)D zP@X&*!;m~4nX@w*hKS9(K<8vii9RQ554Asw?Y@3brSM#M!Pk`@I;KE3K(FaBEe@*VE68IR7tG)yBisLG6 zHe!!~YPpU3+IA!|{axrmyZb^s#=8&ZBam^b^~hZmH@xfz=^(C9$J6s~zzVWcMkH{k z*VNHq&z8sGGAy2geQ%1KTaNJva;)AQ1Px|lJAwy=S828-n@DIOWwDJcaMq+ViPE+s zJYq3`2nx)!yNvo%*{BsEj8Q~+8R~nPmCJ+bIquBoDY4lWftr1yO0~Dd42b}5Yy&vy zCoe_KT_86r`$qN;>r=6^SF#l_;_Iw0PXxX7{Da^uiqsCXZ1 z&}aNmU_RgH3r{3|h5Y5^WaH72wcqW(<7wI4Y@l*AGwX6}`|_^Fn$;QpG3&ud#V9JS z0K07kB2)*;*qmC%x!t?>1}>X4*>m@9U-k&WZlvb?>^{WQTXWey#uzyt z%fXkiWs&xZij;FGW?!H4G|Qu&yeUeU43rIG*Yd>rmq#PBomkoQT)^}r`yi7FnSE8U zyQHo8*(?bMY41du%St0}qSA+Wdanhm#TG>*09NmzJ{D`*8bw*BXucx+&G@O>dAj(i zI_@v~E9W@YvDg^i^Zf)$BBu8zSh(S60(n>_)Tcfh?Pvc@M)5LPsU&ua&iZMAtXr=H zo><;9bd19xgn4zET}H3O^VNNr0(pAx=bw?!N7>%{!l~-MK$#^))#5?sKd=GcEQq_H z=1k;-cYVKAGl`=g$l~pC@i;cxkxORn$8*FLfuj9P_-sLn2^1^cKp!XQY=ya3ZNdmQ z78H?&l#4nJ@E(vBdcOK8g`YY63qE=So2E@RWSynRBNS<4A0TY8Qp|CweGo+3Q6Gb~ z<$lP;tfO*7_z}E&L7nl8sxFAtUdku_ks=Q|Hpm%T2#oBr&_I2bAh zA+l+GDK|c~Y5gK6V2_AUl(caz@({;s`JW{sBo!@x-;*~B;ZmFw?E`;g*II2_*J|uh zCzeAl_np(Io^YqDBxIM5wK z2ck7E^z;2nTo~Ae`9N)qcs zA)kpN_+r)5hCZN{6C#{XQs$a06&?}hAO|54e-OfEKkfqZs!Ay84^&Vmet_;E^t?|>t*hQ$^+Gr>+!Hx zH7d4ObOJ*x=1(S~J*7tu6{sD)BG}bvsO%+A&+inq!B6Q5+scaC*xwRrE5!1OZ=BAL zVXCH0Lv{zt0O)siRc1fJF`NT=YXLp65cL)5MclC zHn!_g;Z+yCudTG0c*;qcBZ1`g-VnYUF3yBZ;t~cd#)BDwjDsALQ#@BR4l_lS7>>#9ycapFLKnj7a8Uq_97$7USt&4J&do~x8q3i6!we7a3pK8Z8s7h z?)w<-xL(5^?}K{0g}V-DlaZXs;#-W3W^FLSfIqAUywNroSFCswwVazmIE;Fby=bI(w#r8C+%!_3j zeKFbkYk7jc9q)a_M5-*n%El8N$*J5ki?ZCr40Mlc4btpm;9e14ie{RLHn%(MmAnVnk4(<^skLHE*FZTPath z0!qAT^!g-#MQbzhfI3!V%j&qNk;5+}SSokgkj0kYf1(VVe!#!l5;y}nFvu>sZ3rz& z+j28;FF10w!qF2n5mwCKYxxY(pA+~wBl4WuBF{U3|lHti;HgL!Hl(j-72kMHB`umO}B%Y3t z$X6Vj`Q`+Nc*?lF@>sd&?g!bI_S}7cdG?cdv!gfg(n7xZ#HQGWAM>ay7@-J6?ra=O zur+o=0dPd3H~Kwk^=X1m(@q7G9!4PJ7}_*3k;x6=1t0V-vIwkyQcVp2T?{?3 z_|!&E#-`R@-QjZgIiN2rADqY^ zA1G@lU{9q|44ldn@|7UiOd0-CWD#Xyipw66x3ChNGNAOQ)s{H6UG@l{?!2u|PPWbN zdp{JpF59-T)$1dr?*lT^*x^zNXq+gdicQZdh+>yrc0k*SiO=3X7xRAdsM z>wCKnMjh}=Wpn*ryuD<*pURg(ThfM{2NY!iuAB!%=wZ+CO9!Jjvu7wnUIL@UYsU&@ z5Xa|4g$GyB9c}A^USiT@WpeV8F?L}GDsFP3;R6GZZ&l>N10GH5zu~AXXt6sv1`&av z%h=_~%Z9MI=0NL!c?i>3>oqK6Ek^iUn7eUx5i zN6+Mq2oNlZuTvBz5Wan(?%a$%Rt#7X84IGsK9t?BKcs-T?}^Gn3BkA>y3-#<5f(2EU__OOl7%QD-Ba>_-9P0PK>5FwgCi^bd;@o>rzfA0 zLUcKyZy(r8U1nA$OjY3wY>1@7@TGjU0YE+(>g!jS!?YoOKX$40giv-#hxl6Prchkqu)94#wFW_NkU<4vhA3X;Q4iZ}0im~VmwZ?#|8IsG z68t8K9@32;{(7X~1U)2r8U069Wsi0gDs)-lS&=`S)QHXSD%}WH->MPP?YK13J|f-Z{`JB)YR4O7-N&eFU9L;JeuzWq09ZLeq&~)!r2V#ISR({{?q6HL)T;`C12O^~y`+XDMG{9==*v>%h>#z4Ij)>4NZL3lB=BVVOE ztsQw4=L_QK1Upva2u@iLsA4c1Q1S_m8WtnJU9|6QPwhU>ocqz7(bQeM#;LCTeKeJ0 z_v)>s{Y;JEmnuf|eu#lj!8B7!U_wwu==||-c?-Y!tLNL1PA|TssK^Soh8sKD+gj?v z&26pT_O|BM@TK0Qv?W1FwWwLjS;w2J8=KcOg*)SErssERJUXo^ax zi;=z+Svp~-mu{GDH8$|zwY;5;^=+*UoyAsl*NsvOww(G3wzM>^ zscRuudso=o(7d*>wG-G#nI>*^b4%kCZ%cD)qqnr!LKIM!Jw~#RB$xechdOq|jGKOv z|B$uBy1A|620O-=XxPndT`djX#&z|L^kS`UcT4ly=CGvog~N?&+r!>)o7Z3I3xyWU z_ARdTcD0(0k>kA2cVgD(3+txNm{#g-TkVy`dm9>CI@{|yIvW*c=$h?xQ)kSa{-Fs~ z@{ucGHC%`9(7A_9zeddSNGugkt#X~N=5igL0EccJZ~xon*`b|&HDsO0-BKL+g%xo6|a`m#I_PUq)jvWOw| zt-oXG&3Py1TL1LhpDcar*~54ARiFLjbI$Fvbhu+y?3VA;oa%qVj5j<6-qBcJyqY4^ zRd`-0G`e7+m#fqpobL^mR{LfLycc?d-UUk*dlyuBD;6x7?_YFYkxEakav8kQbR+Gf zDXQJl_T-3Y+3G+3j+5-|1`pePI$k{wRj;bK;=xEsdQ09{M z_Qnn?)OIuf{sjxGr!KUXNc=+Kn^tAbqF`vjd@EF0wb+`!z`J;%Z~mg11&b=JP~+;b z)N>eD??RQV4>ft;J0{Tke}b0vuLrkWJ$Fu`^tsZ?6#J!wXHWd)1Iof zj+^T`8gwC5DyX?wHGH9ZTD)+P^i^P&xNJDtF+ykE24((|hqj+1p)~+JpMR2OTX{v+GP7ze+ISThr(M4cf4{u_AFuhpO43;pyY~M8+ zTL}|x{{#79zTVeIV+9B^Z$6_P${?1q|YclQlZY;K#a9~F)wq2fo5sPJip8otY7Mmm? z$5KiNOMb%!GokfI`bC&~kaiJvqqv>R#3T28o~a3i5yGUv$UxOJiBSeNTKGiQAE zR)}5V>9RElu3aPv{NokTN%hnC?RfWtn0&3pa_3gL3+8$z-kjZSUGbUA&cApvJ=OV_ z6D}pcE!#-^xA}$nwZHd4tmq7GD%`nuIz#S)Ev|)bZzQY2UAXxqpSxtkIG=mw`tftz zTXS4{Pj+w13AnfOyEiB3-a)vNUqAQz_zmPNbq^8_<+MubyC+U?&!hyOyRgFTt#B7m zLxnrrH}TpD8H%Z(mb}?EtaR^i_}n`kRqlSr)ox;&C6-$G zj^(6wUF#(Ia#Gijx`Na+mbU|>8YCQYRGZW_lKMdxsTU=cJhp@Z4jVp08h4l_IT_h!IzJMTa9a#l;%HS00R@HEa7*H(Ww3J zmNkX4KA^0EbC1V8kJ6&6{A}4JgH*fuTmvj6C=wS};CH)kaWo;`y z9&3en#M4*Y>AF&9Abm}?qz{_(%Sk_2{_)a>C~`CD3-AYd4Bq+?aGLAxcDg<_E-j#{ zr90BzXDM&rHOFITOL=zxf_DFCZqZ57+_`r8oGi=Q3GbILy{Aq8>Zy|6C+TG@W|96F zAFRkfiHF3vR;H&1r|Ye(bc88u8Oz#8S&u$s%%B)*Nr6(p`8@mdo5Nj!(d@C(9z zemZfNRMW5Sj4cFReoWFK#9dAp2Q zK;Iz0am<02jK)4c*&d4z;hQ_$u3o|G6FGQbqHD_O?wxLUrhBe?pL>pbz%7hamSqYb zAElmxYe!=Pgh}|A4u=>=$C3=SSnXslfM&j3HyZnrbfQD%sEloPzCGatW;Kttf}vw4 zp?MRX@17W20n*BpvY9&XMTU9_+?A`4-*)19@E-RKiGVIPJALkg4KAPCyFSag#a#ed zGr4IRdX%)sNP7^v*ZrRx$N9?CdDZXkcDRPp(~zQXY0o6e-54H?y)Sih6+l-d#D$UX z-V`3F==4MAs^8`MSBHC_tHwRREICN4hg@^q!~8~Et;8=R{#rr^!*v5;fM;hHH%xS{ z1%yoQt|pVfb)Snn=WL?pP}Uq%)?CV3%?rsZWk^}B=OyX2X;MlG@W$0aD3v&W$ju@m z+6h(GYbERT#4sI`WQcIs6{3T-SG|RoVIAv83Mt8R>jYWTPGb#V-ds%>D&-0Xa5Y z5N)@(5@VIz7UtiFo$ig!M)Csy%G>U|hO*~U_8r6n80y*PtTJsy4g|Hkon2{L=$q*J zA1-ork_(Pa&h7N6bAf1rOf_7hpVBw(3n zzmlsBuI+HS)}*I@_-xqW-sy5)2gW0u@*98x23=P|4MC_O03y*>O2~JSP6&gUN)f9N zjZkL0yd98ImL(M;bX&*UHS+fN<9S;<=Isje){+Av-)0;N501vpVomjt{n?u3veNfw z&P3N^;~@gXv;Ad~9= z2$i*tx3z})nBlXoLTV$)nsEUg~$RywcsYKyiA+TE|W9nxK1Wg?pvn-Q;t(U+J#N#OOQ!|7TWm$M@;S*XdyY zDY4iE@pXlgF%o=iUVKjQGyS;EOi%a7?pchgnwpp*S@-U6bdbI}ZO0MKo=!>(8+Sm- z84}N(C|{hI#Y7)K*L1fN$dLg?c+DVPp|1$Qt=|v zR+_Y;E%>mstW4tNepuRNlM6GhDZx{qf7TX zn0ikrca14mn&-OvqgrwOe^V=#B)4K`aw|S+s093|r_`{182Dva|DK_8O%n9A5hmS; zB*Q|W{Bc_GaYiHs7JvMEVDaCEw%h2Q=+EHZ(8&&dJDFlqX$Q%}AwXt@>bQoq%n=`& zRw3Nvzo&cuZ9^^dT70O}AdY46{I#UHoab*9{p+un~$9UlhY z`o9Cd_P8||_$nFZHU#0B#j)5Drcb#V_-!Swhq#mCI*c)E)5ID~=2YjrOtYCYy-?ss zHeN|R$EasYDf>5ZnKzw`ZT29B9Ims|ugfbYIu9fBqR`-X3^jhYlO+r?o*evL{%Pcc z>6lQl-q!NL7&#`82Y2*#CU zlhybNvdOAiMBgQdz9?@fWs<)c&TmX`7qF9qs;qM2ocR5`iF4!k0j1GRY!Q8sl!jI3OEU?E+-oeI{Q4s zV&p}T7e1&@bU`-J+AG>1)W`4vb{Z)ggds{@Xj(4Qq1NHP!(Mgw5_n%4TubN|4DX|) zXxi?gR6|WP2;UoWG!n|D~w^go22tdI*&+!W6;163?Fo?PRcKHI5<1V1glfZM(2$Z`DY@lh(vj%%B(c3 zy4o8YkGx!{`cbZLdN+=R&LH)(!wSsIG-N`Y8a;vi`S zN@%QAT0dz;3nS=)00dg}J0{W5cSN6t-Obea9IJS-(i5ohSMyR(bkeANosqO%WWD?w zchh`#`wi}OHK+(`l9a(BL5l1xOO~L!Dd29e(TPw=gBMz3oSJB5dWC|2A{qzu5FeTU zV^z|$#NEC`G#D9bLjxhYmHf|PlTjawiG7<~h4LdVMBH~J0uH|geuw@Boy6uWzvyqk z20QS*+%g?WMtbD7Vb-^qXsBD;kss}S3j$#J|ILpw_UtoVxTKRH{{mIYt=Ui!IB zWH*7!FQ{i^ODuMUfu+RlBW}{xSnQpoxMzvW{#q>dnu(MCju7|CU9s2$VqB@SU8 zo>jQ7=$pO0G>XV7Ws5NDT;}c{BGaI!PAW^$k(x&mbGF~z?p%|$C?o(G*Nv1l1$&<6 zxb8k7D<}dw$`x~mgYODi# zFRHvXUB^|~(CzqTzk;^QRPYBmJQ{R7M%=6D&`n@cH)#cRzrbp`9_*tERtq^sUwCHD9=E@~1 zNV!nmt81otFZvO=?Dy}E#@f`gsn1?}4q=BOm#A{(DlzZH%t)?9Svr(;v0P$%C6_G! zlP{CaTG^`aOgAmB$uH+Ze)2M8Zpn)%zM0NsP}e1O!5E6f^su1V+)+&)iG5jyvl^D zO?Z6S0>zJ!lz95XA>SV;ka{5{U-c^31^tF%7j;$aJ30RLbke|EdZ00&v@-<;XAFZC8KS=H4V?(&uuPb)6Du(V4(mEJzJq_|{Sk&gYS zS}?G*?scA+%4IpN2hzs7tl_lrSypx$M0Hsw#pyS>78lfQ(|KzAc+1BB)c9=6rkm9G zla<|Na-7_|tO;>CPJZW-6XM?F7=7>Jq_{V2{3%MmI5vk%PL7{DHdgBOST=u5e(Mq~ zoA*Qjxj0cibY8mnPgyh1PZxixW%JwA^7Ad5&!)zoW~HNZ7bnkczL=W+49hb3mKtAx zONDgpv1frqYQfPg>#bNKM&Ah=bpki9nWxlQLE?lDJAhA#fsZ{;NV0V0Tx7~wc`i3e zS1I>W{?;+^eiLuci*}Z4xN*R}?S4tSe`hHf}fB@f&r#I*Z2bJ$Cs5C@yv8jBuA-{&;S< z)Y&q^K@-0{} z=jF3Ze94&jB2!Mmm~y6>^yOpHmz(stW75wv=?llCzgorTTIHtw<))ot+ncVxtr_Ao z(M6Xk|5Mg&^Hb?G6CO(S>FQliIpXPJEMF2i(UFF4{8*(w^#pqPorxby7jnkffwVT3 zF9jGNXBz(eH0eJjbm7)`qR#)(!v8=(^orDG;4H0{>vhuSIZtf=aaE2^ll(92SIWD4&^Qq*Qh-T+!RbO(ec zN5;lp=c#zNwPR4HH|TC%m?3=)@pJCpt3OW-m#VPyxycAG7B7K zqec8C6JK+qE=Sp+5r3D7ANiUFm^v3o{I{gP&J*YH@0#=j%D=t#1w(S{hbms~Qm;o% zdh6%9UVEST2|NB@b-n6rA6XA(DCd3R1wJ)n;PYt^L&j_5A5Fh>V13TS(+Sleb=HQv zLKUCdMtPc*A^zG7@n6jl|IaGkZMFM#z3N;9<^OAj^uIOftsb3T*?5tDcZT#M#Cv%^ z_R0Zo^OEE%z@@G;ReXW9bPU`sF?c?7P}ghkIbW{g$Chqc3r+g=f6?P*pXIE}kp4?1 zeNC?}|7xAh>dlb;o5Xuhtk(KD@wsXE+wU`!^J<28*ZA~wI#tEHts$AXx!yNzxHLoh z#l)Xu(j*7%b~!)L<*0L{Bv_ZBoI5kb?=aEMS@R^lk=;ap~(hsV5x7Gce9(Q&2lzN6te1ElWk2*_3{IH2%sSdAM zmOB4T{78oKvr(|5n_te#5bw(nFaB#}yjK29x5u{O=``^pP8dFyveO{EmH1rXFv-9{ zz2t9$UC!A${rAj^EhfI^h=zkYtI4~soA|8(0|)q*T;Epl`ab#p=ftPO=LbzWLq~Ku z$~J|JkDB;_=XJg6ye;uhWGMf=4DsioSW5@zV21eXR6O%eyKc`C(}@V{41rtw7`QcN zDCaIy&JH7AebJ zi9;nWWhX^=z{IZ%>v&~HPW%fQ${#i9OJsq-WzgCh2ONZsn#R!4ISM{!oPbwF#HWKl z=F19iN7iUKC|?WIvn)gU+lfzyKVQp`{(qVBOa4u_U)c^){!i@qOLe?D-%0#0O}wr5 z_yTcq{ilhqiRyN$v)07#GV$IjU5>1C)RpXvvf3A%Ut4RnwTs)y&f*y*#nYx;* z2zQ3NaK>40H8gfKu4(SX=~iucZEbx^TWe#dRa@K8R=cL9ZB<=MZ9}-NqqDZIYn@f! zCf+H-jSa;!OJyUEJ;tbqztDdZCky% zrLC?Z(X?dmiEHa_z<;Ikk6CTI^z;+ zb#q5&xOm#MnKP}1j>eYu4!NI3AuWyVog^tMGf6HkOC;fbhKZg&Z6=M>Ik_*jbn!Dv zi>F^QeVWx$*IrkD1D@ZE1Gw7Ss)fGl%G%2Le$cJ9cFz1IwUq%A8SpQ(YUhL&RQN)* z3#zIXRW7bw?5hY>O2QNzXh@Cd4A*spty=%G`M&Dl>@gtgl-vekYHz~FCg?`~HLKe? z#9Lskav8W9tnO$8iEr*`4mXyUOlP+S4l0+n#b+O@S-3)Ip`QSp48;kNeL&TvO_ z>zb7G&82JW>YHjU+=F&DhIthVR?M!QT09kW6TDl~7_P-@U2V9D3L84h%NJDF)Rq>P z(8`wPRrR&?on4AHlB%k2YsE8ay2=_lZ?0>vwHnqmN*fc6>p&rmqtsgENwv04nvv*H zb4y)AOMP;3-HqCoMgd3j+LY9k-I1DBAk_fjx26KBc#U+g9so9jmbG1-3Z@NR^|c`Q zn#LR3FQ%By+W~_8S z*48z*roL9~YH0&OTH9Lba9g;owYk2w;T9TCnB4klphZjDn$<}KTwqrBTzql$Y~kUH>sGZiTD8Fiw5p-GRfes>$~=^C zxYmxf0H>v+txL5j3B9%FQ9XQ&rj6|y(*@}h$ll!8DDZ~qH_F%~6{4DHPc^BHtZk?Z z*J%|ena6bQRm^-KThf@SLQ}Ckwd{uaHihGO(!3d(PcXIBU9I)CVKt7> zS$MUeuFMRQ1^^mfo80JR1QgaIP3sf}QrpnkR@+q9+8{WQ#Of5ur-ClQt%NlT$~Ly% zM9mFt^ikT;vD);t6BgNWBF)<9akJu78a1ZUn9Rs`aZ;OZXTwey_1d`>F zkOD+z?$p}2PUZ_?t-_oVWip*XLP|hP0XP7xU)xSp5)}jd_FF*2L~fb)5DeFXT*z{3 zx^Uwiu5F%{QqsD{4&(&7(^M)*3@~m47>P2Z1>|MYOd@faTLjk#H7J-wT;4XlIstr;|gQM%cS(Fc#%?nVlah#wNN5}Y`=wM29Tw2TOlMH znISBhYXHycupo;dcr6O@&Rf<({)FKU9X8o_+U>ek%na06yr#9QcvV+(OT&fDuy_^a zs|a2gu3G~Xc-K_d*<=+nNl~5-!yWp~O^qGmay{jtmUoDKb&|o{wYP+=V#N)LxdpO3 zhQTJQScH8NwJCTOH#QmZzNvvi>?fU7%lSHoeQ)MX+9bnK4DndSf=XbJS<3wH1Y$2E zD<*qcWbeb+w=$+ma<>y!|CwtrE8v*kLL}t*PK-=eO-`t|DHt z*!A1?1a@fK36VryW8t@gSh2ye^V@a@cGzI@+3mN}+2IYm7n>gY*|txx!y%Jj+Am$P z+i#++TTQ&3-?lTd!+w*{uHVjY_rJ&FuQ2IsyCpmH8u&^6)A^0fzlAt~iL_5$-qcX= zGx;*b#iRPTOV020>Q{Cs`+Uh)u6eM-uk)Oof8-pUzz*&9+GW_!cK9!2^4od|JM0x_ zut}F)uO0QT+$7g;+ilpPZSQ8MAKU*Qn*8xvZ2Jxq+IVQ^_u4lm{5hf2Z|Ar7TkUYM z{lcUlTmOAy^4sS z`7!gqNM6A`JHNdjTyFAvP5*8DwClCUaT|FBes+G_o@M0<9kX3tCS7)ZJA9pY$@$~^ z$SZaJvHaK0XBRobjl|jYdyT$tlF46VCp6*M{O=Mk^_PrEXXh^(6K{7XIUIu`Do4Q7 zztt!eg^mOK?D}o~aWZjs+f_#MH`t+L_X%@Oy6k%GC^@d0F8}u1b?m5}(1c_2|9@m0 B&UXL+ From c675da5ba363e4bf0a93f713515f5438a0de13c0 Mon Sep 17 00:00:00 2001 From: Tyler Date: Sat, 12 Mar 2022 02:15:59 -0600 Subject: [PATCH 6/8] updated Makefile for macos --- Makefile | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/Makefile b/Makefile index b04dd66..2ed8499 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,7 @@ # Your Fortran 2003 compliant compiler. Must support C bindings to build # delsparsec library (in extras/c_binding). FORT = gfortran +CC = gcc # Set the prefix for your install directory. Installs in-place by default. PREFIX = $(PWD) @@ -10,10 +11,14 @@ PREFIX = $(PWD) # Build without linking CFLAGS = -c -# $OPTS must contain the flag for building OpenMP threadsafe (-fopenmp on GNU). -# You can add additional flags (such as -O3) for code optimization +# $OPTS must contain the flag for building OpenMP threadsafe (-fopenmp on +# gfortran). You can add additional flags (such as -O3) for code optimization. OPTS = -fopenmp -O3 -fPIC +# $COPTS must contain the C compiler (CC) flags for building OpenMP +# threadsafe (-fopenmp on gcc). Can add additional flags, as with $OPTS. +COPTS = -fopenmp + # Link shared objects LFLAGS = -shared @@ -49,10 +54,10 @@ install: include bin lib # Test installation test_install: test/test_install.f90 test/test_c_install.c include/delsparse_mod.mod include/delsparse.h lib/libdelsparse.so lib/libdelsparsec.so bin/delsparses bin/delsparsep - $(FORT) $(OPTS) test/test_install.f90 -I$(PREFIX)/include -L$(PREFIX)/lib -ldelsparse -o test/test_install - export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH):$(PREFIX)/lib && test/test_install - $(FORT) $(OPTS) test/test_c_install.c -I$(PREFIX)/include -L$(PREFIX)/lib -ldelsparsec -o test/test_c_install - export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH):$(PREFIX)/lib && test/test_c_install + $(FORT) $(OPTS) test/test_install.f90 -I$(PREFIX)/include -L$(PREFIX)/lib/ -ldelsparse -o test/test_install + export DYLD_LIBRARY_PATH=$(LD_LIBRARY_PATH):$(PREFIX)/lib/ && test/test_install + $(CC) $(COPTS) test/test_c_install.c -I$(PREFIX)/include -L$(PREFIX)/lib/ -ldelsparsec -o test/test_c_install + export DYLD_LIBRARY_PATH=$(LD_LIBRARY_PATH):$(PREFIX)/lib/ && test/test_c_install test/test_bin.sh # Make shared libs From ad3442a613066d223f99dc77c73c9cbd849dede8 Mon Sep 17 00:00:00 2001 From: Tyler Date: Tue, 31 May 2022 13:31:08 -0500 Subject: [PATCH 7/8] restructured --- Makefile | 115 - README.md | 48 +- data/varsys/sample_input2d.dat | 188 - data/varsys/sample_input4d.dat | 1297 ----- extras/c_binding/LICENSE | 22 - extras/c_binding/Makefile | 25 - extras/c_binding/README | 42 - extras/c_binding/delsparse.f90 | 2778 --------- extras/c_binding/delsparse.h | 59 - extras/c_binding/delsparse_bind_c.f90 | 1265 ----- extras/c_binding/dependencies/blas.f | 2206 -------- extras/c_binding/dependencies/lapack.f | 4369 -------------- extras/c_binding/dependencies/slatec.f | 5023 ---------------- extras/c_binding/test_install | Bin 276896 -> 0 bytes extras/c_binding/test_install.c | 149 - extras/delsparsepy/LICENSE | 22 - extras/delsparsepy/README | 44 - extras/delsparsepy/delsparse.py | 759 --- extras/delsparsepy/delsparse_src/blas.f | 2206 -------- .../delsparsepy/delsparse_src/delsparse.f90 | 2774 --------- .../delsparse_src/delsparse_bind_c.f90 | 4422 --------------- extras/delsparsepy/delsparse_src/lapack.f | 4369 -------------- .../delsparse_src/real_precision.f90 | 4 - extras/delsparsepy/delsparse_src/slatec.f | 5023 ---------------- extras/delsparsepy/example.py | 131 - src/dependencies/blas.f | 2206 -------- src/dependencies/lapack.f | 4369 -------------- src/dependencies/slatec.f | 5023 ---------------- test/test_bin.sh | 46 - test/test_c_install.c | 149 - test/test_install.f90 | 153 - toms1012/LICENSE | 22 - toms1012/Makefile | 31 - toms1012/README | 83 - toms1012/blas.f | 2206 -------- toms1012/delsparse.f90 | 2778 --------- toms1012/lapack.f | 4369 -------------- toms1012/sample_input2d.dat | 188 - toms1012/sample_input4d.dat | 1297 ----- toms1012/samplep.f90 | 155 - toms1012/samples.f90 | 155 - toms1012/slatec.f | 5037 ----------------- toms1012/test_install.f90 | 153 - 43 files changed, 21 insertions(+), 65739 deletions(-) delete mode 100644 Makefile delete mode 100644 data/varsys/sample_input2d.dat delete mode 100644 data/varsys/sample_input4d.dat delete mode 100644 extras/c_binding/LICENSE delete mode 100644 extras/c_binding/Makefile delete mode 100644 extras/c_binding/README delete mode 100644 extras/c_binding/delsparse.f90 delete mode 100644 extras/c_binding/delsparse.h delete mode 100644 extras/c_binding/delsparse_bind_c.f90 delete mode 100644 extras/c_binding/dependencies/blas.f delete mode 100644 extras/c_binding/dependencies/lapack.f delete mode 100644 extras/c_binding/dependencies/slatec.f delete mode 100755 extras/c_binding/test_install delete mode 100644 extras/c_binding/test_install.c delete mode 100644 extras/delsparsepy/LICENSE delete mode 100644 extras/delsparsepy/README delete mode 100644 extras/delsparsepy/delsparse.py delete mode 100755 extras/delsparsepy/delsparse_src/blas.f delete mode 100644 extras/delsparsepy/delsparse_src/delsparse.f90 delete mode 100644 extras/delsparsepy/delsparse_src/delsparse_bind_c.f90 delete mode 100755 extras/delsparsepy/delsparse_src/lapack.f delete mode 100644 extras/delsparsepy/delsparse_src/real_precision.f90 delete mode 100755 extras/delsparsepy/delsparse_src/slatec.f delete mode 100644 extras/delsparsepy/example.py delete mode 100644 src/dependencies/blas.f delete mode 100644 src/dependencies/lapack.f delete mode 100644 src/dependencies/slatec.f delete mode 100755 test/test_bin.sh delete mode 100644 test/test_c_install.c delete mode 100644 test/test_install.f90 delete mode 100644 toms1012/LICENSE delete mode 100644 toms1012/Makefile delete mode 100644 toms1012/README delete mode 100644 toms1012/blas.f delete mode 100644 toms1012/delsparse.f90 delete mode 100644 toms1012/lapack.f delete mode 100644 toms1012/sample_input2d.dat delete mode 100644 toms1012/sample_input4d.dat delete mode 100644 toms1012/samplep.f90 delete mode 100644 toms1012/samples.f90 delete mode 100644 toms1012/slatec.f delete mode 100644 toms1012/test_install.f90 diff --git a/Makefile b/Makefile deleted file mode 100644 index 2ed8499..0000000 --- a/Makefile +++ /dev/null @@ -1,115 +0,0 @@ -# Your Fortran 2003 compliant compiler. Must support C bindings to build -# delsparsec library (in extras/c_binding). -FORT = gfortran -CC = gcc - -# Set the prefix for your install directory. Installs in-place by default. -PREFIX = $(PWD) - -# Compiler flags defined below. - -# Build without linking -CFLAGS = -c - -# $OPTS must contain the flag for building OpenMP threadsafe (-fopenmp on -# gfortran). You can add additional flags (such as -O3) for code optimization. -OPTS = -fopenmp -O3 -fPIC - -# $COPTS must contain the C compiler (CC) flags for building OpenMP -# threadsafe (-fopenmp on gcc). Can add additional flags, as with $OPTS. -COPTS = -fopenmp - -# Link shared objects -LFLAGS = -shared - -# Legacy flag, used for suppressing warnings when building SLATEC -LEGACY = -std=legacy - -# Dependencies: Replace with appropriate linker flag (e.g., -llapack -lblas) -# if you have these libraries already installed on your computer. -# Otherwise, the value below will use the included minimal copies, taken -# from the public domain. -# Note that there is a known issue that occurs during extrapolation when -# linking against the public version of lapack.f. -LIBS = dependencies/lapack.f dependencies/blas.f - - -# Build formula: - -# Make all library/module files - -all: src/libdelsparse.so src/delsparses src/delsparsep extras/c_binding/libdelsparsec.so - -# Copy all libraries, module files, and binaries into their install locations - -install: include bin lib - cp src/libdelsparse.so $(PREFIX)/lib/libdelsparse.so - cp src/delsparse_mod.mod $(PREFIX)/include/delsparse_mod.mod - cp src/real_precision.mod $(PREFIX)/include/real_precision.mod - cp src/delsparses $(PREFIX)/bin/delsparses - cp src/delsparsep $(PREFIX)/bin/delsparsep - cp extras/c_binding/libdelsparsec.so $(PREFIX)/lib/libdelsparsec.so - cp extras/c_binding/delsparse.h $(PREFIX)/include/delsparse.h - -# Test installation - -test_install: test/test_install.f90 test/test_c_install.c include/delsparse_mod.mod include/delsparse.h lib/libdelsparse.so lib/libdelsparsec.so bin/delsparses bin/delsparsep - $(FORT) $(OPTS) test/test_install.f90 -I$(PREFIX)/include -L$(PREFIX)/lib/ -ldelsparse -o test/test_install - export DYLD_LIBRARY_PATH=$(LD_LIBRARY_PATH):$(PREFIX)/lib/ && test/test_install - $(CC) $(COPTS) test/test_c_install.c -I$(PREFIX)/include -L$(PREFIX)/lib/ -ldelsparsec -o test/test_c_install - export DYLD_LIBRARY_PATH=$(LD_LIBRARY_PATH):$(PREFIX)/lib/ && test/test_c_install - test/test_bin.sh - -# Make shared libs - -extras/c_binding/libdelsparsec.so: src/dependencies/slatec.o extras/c_binding/delsparsec.o - cp src/dependencies/slatec.o extras/c_binding/dependencies/slatec.o - cd extras/c_binding && $(FORT) $(LFLAGS) $(OPTS) delsparsec.o delsparse.o dependencies/slatec.o $(LIBS) -o libdelsparsec.so - -src/libdelsparse.so: src/dependencies/slatec.o src/delsparse.o - cd src && $(FORT) $(LFLAGS) $(OPTS) delsparse.o dependencies/slatec.o $(LIBS) -o libdelsparse.so - -# Make bin execs - -src/delsparses: src/samples.f90 src/delsparse.o src/dependencies/slatec.o - cd src && $(FORT) $(OPTS) samples.f90 delsparse.o dependencies/slatec.o $(LIBS) -o delsparses - -src/delsparsep: src/samplep.f90 src/delsparse.o src/dependencies/slatec.o - cd src && $(FORT) $(OPTS) samplep.f90 delsparse.o dependencies/slatec.o $(LIBS) -o delsparsep - -# Make C bindings - -extras/c_binding/delsparsec.o: extras/c_binding/delsparse_bind_c.f90 - cd extras/c_binding && $(FORT) $(CFLAGS) $(OPTS) delsparse.f90 -o delsparse.o - cd extras/c_binding && $(FORT) $(CFLAGS) $(OPTS) delsparse_bind_c.f90 -o delsparsec.o - -# Make delsparse.o and slatec.o - -src/delsparse.o: src/delsparse.f90 - cd src && $(FORT) $(CFLAGS) $(OPTS) delsparse.f90 -o delsparse.o - -src/dependencies/slatec.o : src/dependencies/slatec.f - cd src/dependencies && $(FORT) $(CFLAGS) $(OPTS) $(LEGACY) slatec.f -o slatec.o - -# Make install directories - -include: - mkdir include - -lib: - mkdir lib - -bin: - mkdir bin - -# Clean command - -clean: - cd src && rm -f *.o *.mod *.so delsparses delsparsep - cd src/dependencies && rm -f *.o - cd extras/c_binding && rm -f *.o *.mod *.so - cd extras/c_binding/dependencies && rm -f *.o - cd lib && rm -f *.so - cd bin && rm -f delsparses delsparsep - cd include && rm -f delsparse.h *.mod - cd test && rm -f test_install test_c_install diff --git a/README.md b/README.md index e3c6be3..bdaad61 100644 --- a/README.md +++ b/README.md @@ -11,7 +11,7 @@ Command line drivers are also provided with the original Fortran code. `DELAUNAYSPARSE` contains several modes of operation. -At the most basic level, the two driver subroutines are as follows. +In the original ACM TOMS release, two Fortran driver subroutines were provided: * `DELAUNAYSPARSES` runs the serial driver to identify the vertices of the simplex/simplices containing one or more interpolation points. Can also (optionally) be set to compute and return the value of the @@ -27,42 +27,36 @@ from files: * `delsparses` (uses the serial driver), and * `delsparsep` (uses the parallel driver). -In the `extras` directory, there are two additional interfaces for calling -from C/C++ (`extras/c_binding`) and Python 3 (`extras/delsparsepy`). +In this repository, two additional interfaces are provided for calling +from C/C++ (`c_binding`) and Python 3 (`python`). -Further detailed user information is documented in the USAGE document. +Further detailed user information is documented in the `USAGE` document. ## Organization The physical organization is as follows. - * `toms1012` contains the original unmodified Fortran source code, as - published in ACM TOMS Algorithm 1012. This includes 2 command line drivers + * `src` contains the original unmodified Fortran source code, as published + in ACM TOMS Algorithm 1012. This includes 2 command line drivers `samples.f90` (serial driver) and `samplep.f90` (parallel driver), which can be used on formatted data files from the command line. Comments at the top of each subroutine document their usage. See this directory's internal README for further information on - building, testing, and usage. The directory can be independently - downloaded and is fully portable. - * `src` contains the latest project source, which has been configured - to easily install using modern package managers. - * `test` contains basic regression test cases for each major mode of - operation, so that the installation can be tested. - * `data` contains several real-world data files (exhibiting degeneracy), - for testing the installation and providing a sample for the CL interface. - * `extras` contains the C bindings (`c_binding`) and DelaunaySparse for - Python (`delsparsepy`). For convenience, copies of all source code and - dependencies are duplicated in each of these directories. - * A GNU Makefile is provided for building, installing, and running tests. - Define your Fortran compiler and options at the top of the file, and - (optionally) set the install directory by setting the $(PREFIX) variable. - Then use `make` to build binaries, `make install` to install binaries, - and `make test_install` to test the installation. - Binary executables will install in `$(PREFIX)/bin`, headers will install - to `$(PREFIX)/include`, and shared libraries will install to - `$(PREFIX)/lib`. Running these commands also builds/installs/tests the - C interface, `delsparsec`. The Python extras must be installed separately. - * USAGE provides additional detailed user information. + building, testing, and usage. + * `python` contains a Python3 wrapper for the Fortran code, allowing + DELAUNAYSPARSE to be directly imported as a Python package. This wrapper + was created by modifying the output generated by fmodpy. The script + `example.py` demonstrates its usage. For convenience, copies of all + Fortran code that is used by the Python wrapper are also included in + this directory. + * `c_binding` contains C bindings for several variations of the main + Fortran subroutines, as well as copies of the Fortran source code. + A test file `test_install.c` can be used for usage examples. This + directory's internal README also contains best practices when calling + Fortran from C/C++. + * `USAGE` provides additional detailed user information. + * DelaunaySparse is shared under the MIT Software License, in the `LICENSE` + file. ## Citation diff --git a/data/varsys/sample_input2d.dat b/data/varsys/sample_input2d.dat deleted file mode 100644 index 1ebeed6..0000000 --- a/data/varsys/sample_input2d.dat +++ /dev/null @@ -1,188 +0,0 @@ -2,43,101,1 --0.737779900597,-0.675041345605 --0.737779900597,0.587602108436 -0.524863553445,-0.675041345605 -0.524863553445,0.587602108436 --0.663506756241,0.166253571025 --0.584282068929,-0.394609706728 --0.584282068929,0.446685209901 --0.584282068929,0.586901029339 --0.425832694304,-0.534825526166 --0.425832694304,-0.464717616447 --0.425832694304,-0.184285977571 --0.425832694304,-0.0440701581327 --0.425832694304,0.0961456613055 --0.425832694304,0.236361480744 --0.425832694304,0.51679311962 --0.108933945055,-0.675041345605 --0.108933945055,-0.534825526166 --0.108933945055,-0.464717616447 --0.108933945055,-0.394609706728 --0.108933945055,-0.25439388729 --0.108933945055,-0.184285977571 --0.108933945055,-0.114178067852 --0.108933945055,-0.0440701581327 --0.108933945055,0.0961456613055 --0.108933945055,0.166253571025 --0.108933945055,0.236361480744 --0.108933945055,0.376577300182 --0.108933945055,0.51679311962 --0.108933945055,0.587602108436 -0.524863553445,-0.534825526166 -0.524863553445,-0.464717616447 -0.524863553445,-0.394609706728 -0.524863553445,-0.25439388729 -0.524863553445,-0.184285977571 -0.524863553445,-0.114178067852 -0.524863553445,-0.0440701581327 -0.524863553445,0.0961456613055 -0.524863553445,0.166253571025 -0.524863553445,0.236361480744 -0.524863553445,0.376577300182 -0.524863553445,0.446685209901 -0.524863553445,0.51679311962 -0.524863553445,0.586901029339 -296835782027 -736030395045 -1.06918217819E+016 -3.20566930178E+016 -73374496803300 -189039708822000 -273719385634000 -326069037783000 -675040018268000 -756967336463000 -914266006037000 -1.0830311159E+015 -1218388638980000 -1326756634210000 -1463454444460000 -2.5144413074E+015 -2.77933373432E+015 -2836545644680000 -3155262430390000 -3451182362430000 -3715001247780000 -3896447879110000 -4.11531577031E+015 -4745519778190000 -4840384897050000 -5228331120200000 -5481722046370000 -6250890553900000 -7367804014150000 -1.16388102101E+016 -1.11174656608E+016 -1.25221884669E+016 -1.49468718462E+016 -1.468022513E+016 -1.54642127154E+016 -1.65072763423E+016 -2.08248675151E+016 -1.86574133761E+016 -2.01386128979E+016 -2.38441779462E+016 -2.52856646169E+016 -2.56482815535E+016 -2.78334409382E+016 --0.737779900597,-0.534825526166 --0.737779900597,-0.464717616447 --0.737779900597,-0.394609706728 --0.737779900597,-0.25439388729 --0.737779900597,-0.184285977571 --0.737779900597,-0.114178067852 --0.737779900597,-0.0440701581327 --0.737779900597,0.0961456613055 --0.737779900597,0.166253571025 --0.737779900597,0.236361480744 --0.737779900597,0.376577300182 --0.737779900597,0.446685209901 --0.737779900597,0.51679311962 --0.737779900597,0.586901029339 --0.73282835764,-0.675041345605 --0.73282835764,-0.534825526166 --0.73282835764,-0.464717616447 --0.73282835764,-0.394609706728 --0.73282835764,-0.25439388729 --0.73282835764,-0.184285977571 --0.73282835764,-0.114178067852 --0.73282835764,-0.0440701581327 --0.73282835764,0.0961456613055 --0.73282835764,0.166253571025 --0.73282835764,0.236361480744 --0.73282835764,0.376577300182 --0.73282835764,0.446685209901 --0.73282835764,0.51679311962 --0.73282835764,0.586901029339 --0.73282835764,0.587602108436 --0.722925271725,-0.675041345605 --0.722925271725,-0.534825526166 --0.722925271725,-0.464717616447 --0.722925271725,-0.394609706728 --0.722925271725,-0.25439388729 --0.722925271725,-0.184285977571 --0.722925271725,-0.114178067852 --0.722925271725,-0.0440701581327 --0.722925271725,0.0961456613055 --0.722925271725,0.166253571025 --0.722925271725,0.236361480744 --0.722925271725,0.376577300182 --0.722925271725,0.446685209901 --0.722925271725,0.51679311962 --0.722925271725,0.586901029339 --0.722925271725,0.587602108436 --0.703119099897,-0.675041345605 --0.703119099897,-0.534825526166 --0.703119099897,-0.464717616447 --0.703119099897,-0.394609706728 --0.703119099897,-0.25439388729 --0.703119099897,-0.184285977571 --0.703119099897,-0.114178067852 --0.703119099897,-0.0440701581327 --0.703119099897,0.0961456613055 --0.703119099897,0.166253571025 --0.703119099897,0.236361480744 --0.703119099897,0.376577300182 --0.703119099897,0.446685209901 --0.703119099897,0.51679311962 --0.703119099897,0.586901029339 --0.703119099897,0.587602108436 --0.663506756241,-0.675041345605 --0.663506756241,-0.534825526166 --0.663506756241,-0.464717616447 --0.663506756241,-0.394609706728 --0.663506756241,-0.25439388729 --0.663506756241,-0.184285977571 --0.663506756241,-0.114178067852 --0.663506756241,-0.0440701581327 --0.663506756241,0.0961456613055 --0.663506756241,0.236361480744 --0.663506756241,0.376577300182 --0.663506756241,0.446685209901 --0.663506756241,0.51679311962 --0.663506756241,0.586901029339 --0.663506756241,0.587602108436 --0.584282068929,-0.675041345605 --0.584282068929,-0.534825526166 --0.584282068929,-0.464717616447 --0.584282068929,-0.25439388729 --0.584282068929,-0.184285977571 --0.584282068929,-0.114178067852 --0.584282068929,-0.0440701581327 --0.584282068929,0.0961456613055 --0.584282068929,0.166253571025 --0.584282068929,0.236361480744 --0.584282068929,0.376577300182 --0.584282068929,0.51679311962 --0.584282068929,0.587602108436 --0.425832694304,-0.675041345605 --0.425832694304,-0.394609706728 --0.425832694304,-0.25439388729 --0.425832694304,-0.114178067852 --0.425832694304,0.166253571025 --0.425832694304,0.376577300182 --0.425832694304,0.446685209901 --0.425832694304,0.586901029339 --0.425832694304,0.587602108436 --0.108933945055,0.446685209901 --0.108933945055,0.586901029339 diff --git a/data/varsys/sample_input4d.dat b/data/varsys/sample_input4d.dat deleted file mode 100644 index f786eda..0000000 --- a/data/varsys/sample_input4d.dat +++ /dev/null @@ -1,1297 +0,0 @@ -4,432,432,1 --0.429559544383,-0.141336559823,-0.324322498044,-0.452914378473 --0.429559544383,-0.141336559823,-0.324322498044,0.346266169217 --0.429559544383,-0.141336559823,0.474858049646,-0.452914378473 --0.429559544383,-0.141336559823,0.474858049646,0.346266169217 -0.369621003307,-0.141336559823,-0.324322498044,-0.452914378473 -0.369621003307,-0.141336559823,-0.324322498044,0.346266169217 -0.369621003307,-0.141336559823,0.474858049646,-0.452914378473 -0.369621003307,-0.141336559823,0.474858049646,0.346266169217 -0.369621003307,0.657843987867,-0.324322498044,-0.452914378473 -0.369621003307,0.657843987867,-0.324322498044,0.346266169217 -0.369621003307,0.657843987867,0.474858049646,-0.452914378473 -0.369621003307,0.657843987867,0.474858049646,0.346266169217 --0.429559544383,-0.141336559823,-0.302384208499,-0.452914378473 --0.429559544383,-0.141336559823,-0.302384208499,0.21269962571 --0.429559544383,-0.141336559823,-0.277311877591,-0.452914378473 --0.429559544383,-0.141336559823,-0.277311877591,-0.364165844582 --0.429559544383,-0.141336559823,-0.277311877591,-0.275417310691 --0.429559544383,-0.141336559823,-0.277311877591,0.0795768248736 --0.429559544383,-0.141336559823,-0.277311877591,0.123951091819 --0.429559544383,-0.141336559823,-0.277311877591,0.21269962571 --0.429559544383,-0.141336559823,-0.277311877591,0.345822426547 --0.429559544383,-0.141336559823,-0.277311877591,0.346266169217 --0.429559544383,-0.141336559823,-0.227167215775,-0.1866687768 --0.429559544383,-0.141336559823,-0.227167215775,-0.142294509854 --0.429559544383,-0.141336559823,-0.227167215775,-0.0979202429087 --0.429559544383,-0.141336559823,-0.227167215775,-0.0535459759631 --0.429559544383,-0.141336559823,-0.227167215775,0.0352025579281 --0.429559544383,-0.141336559823,-0.227167215775,0.0795768248736 --0.429559544383,-0.141336559823,-0.227167215775,0.123951091819 --0.429559544383,-0.141336559823,-0.227167215775,0.21269962571 --0.429559544383,-0.141336559823,-0.227167215775,0.257073892656 --0.429559544383,-0.141336559823,-0.227167215775,0.301448159602 --0.429559544383,-0.141336559823,-0.227167215775,0.345822426547 --0.429559544383,-0.141336559823,-0.227167215775,0.346266169217 --0.429559544383,-0.141336559823,-0.126877892144,-0.364165844582 --0.429559544383,-0.141336559823,-0.126877892144,-0.319791577637 --0.429559544383,-0.141336559823,-0.126877892144,-0.275417310691 --0.429559544383,-0.141336559823,-0.126877892144,-0.1866687768 --0.429559544383,-0.141336559823,-0.126877892144,-0.142294509854 --0.429559544383,-0.141336559823,-0.126877892144,-0.0979202429087 --0.429559544383,-0.141336559823,-0.126877892144,-0.0535459759631 --0.429559544383,-0.141336559823,-0.126877892144,0.0352025579281 --0.429559544383,-0.141336559823,-0.126877892144,0.0795768248736 --0.429559544383,-0.141336559823,-0.126877892144,0.123951091819 --0.429559544383,-0.141336559823,-0.126877892144,0.21269962571 --0.429559544383,-0.141336559823,-0.126877892144,0.257073892656 --0.429559544383,-0.141336559823,-0.126877892144,0.301448159602 --0.429559544383,-0.141336559823,-0.126877892144,0.345822426547 --0.429559544383,-0.141336559823,-0.126877892144,0.346266169217 --0.429559544383,-0.141336559823,0.0737007551197,-0.452914378473 --0.429559544383,-0.141336559823,0.0737007551197,-0.364165844582 --0.429559544383,-0.141336559823,0.0737007551197,-0.319791577637 --0.429559544383,-0.141336559823,0.0737007551197,-0.275417310691 --0.429559544383,-0.141336559823,0.0737007551197,-0.1866687768 --0.429559544383,-0.141336559823,0.0737007551197,-0.142294509854 --0.429559544383,-0.141336559823,0.0737007551197,-0.0979202429087 --0.429559544383,-0.141336559823,0.0737007551197,-0.0535459759631 --0.429559544383,-0.141336559823,0.0737007551197,0.0352025579281 --0.429559544383,-0.141336559823,0.0737007551197,0.0795768248736 --0.429559544383,-0.141336559823,0.0737007551197,0.123951091819 --0.429559544383,-0.141336559823,0.0737007551197,0.21269962571 --0.429559544383,-0.141336559823,0.0737007551197,0.257073892656 --0.429559544383,-0.141336559823,0.0737007551197,0.301448159602 --0.429559544383,-0.141336559823,0.0737007551197,0.345822426547 --0.429559544383,-0.141336559823,0.0737007551197,0.346266169217 --0.429559544383,-0.141336559823,0.474858049646,-0.364165844582 --0.429559544383,-0.141336559823,0.474858049646,-0.319791577637 --0.429559544383,-0.141336559823,0.474858049646,-0.275417310691 --0.429559544383,-0.141336559823,0.474858049646,-0.1866687768 --0.429559544383,-0.141336559823,0.474858049646,-0.142294509854 --0.429559544383,-0.141336559823,0.474858049646,-0.0979202429087 --0.429559544383,-0.141336559823,0.474858049646,-0.0535459759631 --0.429559544383,-0.141336559823,0.474858049646,0.0352025579281 --0.429559544383,-0.141336559823,0.474858049646,0.0795768248736 --0.429559544383,-0.141336559823,0.474858049646,0.123951091819 --0.429559544383,-0.141336559823,0.474858049646,0.21269962571 --0.429559544383,-0.141336559823,0.474858049646,0.257073892656 --0.429559544383,-0.141336559823,0.474858049646,0.301448159602 --0.429559544383,-0.141336559823,0.474858049646,0.345822426547 --0.269723434845,-0.141336559823,-0.32118845668,0.21269962571 --0.269723434845,-0.141336559823,-0.314920373953,0.0352025579281 --0.269723434845,-0.141336559823,-0.314920373953,0.0795768248736 --0.269723434845,-0.141336559823,-0.314920373953,0.301448159602 --0.269723434845,-0.141336559823,-0.302384208499,-0.364165844582 --0.269723434845,-0.141336559823,-0.302384208499,-0.275417310691 --0.269723434845,-0.141336559823,-0.302384208499,-0.1866687768 --0.269723434845,-0.141336559823,-0.302384208499,-0.0979202429087 --0.269723434845,-0.141336559823,-0.302384208499,0.0795768248736 --0.269723434845,-0.141336559823,-0.302384208499,0.301448159602 --0.269723434845,-0.141336559823,-0.277311877591,-0.452914378473 --0.269723434845,-0.141336559823,-0.277311877591,-0.275417310691 --0.269723434845,-0.141336559823,-0.277311877591,-0.142294509854 --0.269723434845,-0.141336559823,-0.277311877591,-0.0979202429087 --0.269723434845,-0.141336559823,-0.277311877591,0.0352025579281 --0.269723434845,-0.141336559823,-0.277311877591,0.0795768248736 --0.269723434845,-0.141336559823,-0.277311877591,0.123951091819 --0.269723434845,-0.141336559823,-0.277311877591,0.21269962571 --0.269723434845,-0.141336559823,-0.277311877591,0.257073892656 --0.269723434845,-0.141336559823,-0.277311877591,0.345822426547 --0.269723434845,-0.141336559823,-0.277311877591,0.346266169217 --0.269723434845,-0.141336559823,-0.227167215775,-0.452914378473 --0.269723434845,-0.141336559823,-0.227167215775,-0.364165844582 --0.269723434845,-0.141336559823,-0.227167215775,-0.319791577637 --0.269723434845,-0.141336559823,-0.227167215775,-0.275417310691 --0.269723434845,-0.141336559823,-0.227167215775,-0.0979202429087 --0.269723434845,-0.141336559823,-0.227167215775,-0.0535459759631 --0.269723434845,-0.141336559823,-0.227167215775,0.0352025579281 --0.269723434845,-0.141336559823,-0.227167215775,0.0795768248736 --0.269723434845,-0.141336559823,-0.227167215775,0.123951091819 --0.269723434845,-0.141336559823,-0.227167215775,0.21269962571 --0.269723434845,-0.141336559823,-0.227167215775,0.257073892656 --0.269723434845,-0.141336559823,-0.227167215775,0.301448159602 --0.269723434845,-0.141336559823,-0.227167215775,0.345822426547 --0.269723434845,-0.141336559823,-0.227167215775,0.346266169217 --0.269723434845,-0.141336559823,-0.126877892144,-0.452914378473 --0.269723434845,-0.141336559823,-0.126877892144,-0.364165844582 --0.269723434845,-0.141336559823,-0.126877892144,-0.319791577637 --0.269723434845,-0.141336559823,-0.126877892144,-0.275417310691 --0.269723434845,-0.141336559823,-0.126877892144,-0.1866687768 --0.269723434845,-0.141336559823,-0.126877892144,-0.142294509854 --0.269723434845,-0.141336559823,-0.126877892144,-0.0979202429087 --0.269723434845,-0.141336559823,-0.126877892144,-0.0535459759631 --0.269723434845,-0.141336559823,-0.126877892144,0.0352025579281 --0.269723434845,-0.141336559823,-0.126877892144,0.0795768248736 --0.269723434845,-0.141336559823,-0.126877892144,0.123951091819 --0.269723434845,-0.141336559823,-0.126877892144,0.21269962571 --0.269723434845,-0.141336559823,-0.126877892144,0.257073892656 --0.269723434845,-0.141336559823,-0.126877892144,0.301448159602 --0.269723434845,-0.141336559823,-0.126877892144,0.345822426547 --0.269723434845,-0.141336559823,-0.126877892144,0.346266169217 --0.269723434845,-0.141336559823,0.0737007551197,-0.452914378473 --0.269723434845,-0.141336559823,0.0737007551197,-0.364165844582 --0.269723434845,-0.141336559823,0.0737007551197,-0.319791577637 --0.269723434845,-0.141336559823,0.0737007551197,-0.275417310691 --0.269723434845,-0.141336559823,0.0737007551197,-0.1866687768 --0.269723434845,-0.141336559823,0.0737007551197,-0.142294509854 --0.269723434845,-0.141336559823,0.0737007551197,-0.0979202429087 --0.269723434845,-0.141336559823,0.0737007551197,-0.0535459759631 --0.269723434845,-0.141336559823,0.0737007551197,0.0352025579281 --0.269723434845,-0.141336559823,0.0737007551197,0.0795768248736 --0.269723434845,-0.141336559823,0.0737007551197,0.123951091819 --0.269723434845,-0.141336559823,0.0737007551197,0.21269962571 --0.269723434845,-0.141336559823,0.0737007551197,0.257073892656 --0.269723434845,-0.141336559823,0.0737007551197,0.301448159602 --0.269723434845,-0.141336559823,0.0737007551197,0.345822426547 --0.269723434845,-0.141336559823,0.0737007551197,0.346266169217 --0.269723434845,-0.141336559823,0.474858049646,-0.452914378473 --0.269723434845,-0.141336559823,0.474858049646,-0.364165844582 --0.269723434845,-0.141336559823,0.474858049646,-0.319791577637 --0.269723434845,-0.141336559823,0.474858049646,-0.275417310691 --0.269723434845,-0.141336559823,0.474858049646,-0.1866687768 --0.269723434845,-0.141336559823,0.474858049646,-0.142294509854 --0.269723434845,-0.141336559823,0.474858049646,-0.0979202429087 --0.269723434845,-0.141336559823,0.474858049646,-0.0535459759631 --0.269723434845,-0.141336559823,0.474858049646,0.0352025579281 --0.269723434845,-0.141336559823,0.474858049646,0.0795768248736 --0.269723434845,-0.141336559823,0.474858049646,0.123951091819 --0.269723434845,-0.141336559823,0.474858049646,0.21269962571 --0.269723434845,-0.141336559823,0.474858049646,0.257073892656 --0.269723434845,-0.141336559823,0.474858049646,0.301448159602 --0.269723434845,-0.141336559823,0.474858049646,0.345822426547 --0.269723434845,-0.141336559823,0.474858049646,0.346266169217 --0.269723434845,0.018499549715,-0.324322498044,-0.452914378473 --0.269723434845,0.018499549715,-0.314920373953,0.0795768248736 --0.269723434845,0.018499549715,-0.314920373953,0.301448159602 --0.269723434845,0.018499549715,-0.314920373953,0.346266169217 --0.269723434845,0.018499549715,-0.302384208499,-0.452914378473 --0.269723434845,0.018499549715,-0.302384208499,0.0795768248736 --0.269723434845,0.018499549715,-0.302384208499,0.21269962571 --0.269723434845,0.018499549715,-0.302384208499,0.345822426547 --0.269723434845,0.018499549715,-0.277311877591,-0.452914378473 --0.269723434845,0.018499549715,-0.277311877591,-0.364165844582 --0.269723434845,0.018499549715,-0.277311877591,-0.275417310691 --0.269723434845,0.018499549715,-0.277311877591,-0.0979202429087 --0.269723434845,0.018499549715,-0.277311877591,0.0795768248736 --0.269723434845,0.018499549715,-0.277311877591,0.123951091819 --0.269723434845,0.018499549715,-0.277311877591,0.21269962571 --0.269723434845,0.018499549715,-0.277311877591,0.301448159602 --0.269723434845,0.018499549715,-0.277311877591,0.345822426547 --0.269723434845,0.018499549715,-0.227167215775,-0.452914378473 --0.269723434845,0.018499549715,-0.227167215775,-0.364165844582 --0.269723434845,0.018499549715,-0.227167215775,-0.319791577637 --0.269723434845,0.018499549715,-0.227167215775,-0.275417310691 --0.269723434845,0.018499549715,-0.227167215775,-0.1866687768 --0.269723434845,0.018499549715,-0.227167215775,-0.142294509854 --0.269723434845,0.018499549715,-0.227167215775,-0.0979202429087 --0.269723434845,0.018499549715,-0.227167215775,-0.0535459759631 --0.269723434845,0.018499549715,-0.227167215775,0.0352025579281 --0.269723434845,0.018499549715,-0.227167215775,0.0795768248736 --0.269723434845,0.018499549715,-0.227167215775,0.257073892656 --0.269723434845,0.018499549715,-0.227167215775,0.301448159602 --0.269723434845,0.018499549715,-0.227167215775,0.345822426547 --0.269723434845,0.018499549715,-0.227167215775,0.346266169217 --0.269723434845,0.018499549715,-0.126877892144,-0.452914378473 --0.269723434845,0.018499549715,-0.126877892144,-0.364165844582 --0.269723434845,0.018499549715,-0.126877892144,-0.319791577637 --0.269723434845,0.018499549715,-0.126877892144,-0.275417310691 --0.269723434845,0.018499549715,-0.126877892144,-0.1866687768 --0.269723434845,0.018499549715,-0.126877892144,-0.142294509854 --0.269723434845,0.018499549715,-0.126877892144,-0.0979202429087 --0.269723434845,0.018499549715,-0.126877892144,-0.0535459759631 --0.269723434845,0.018499549715,-0.126877892144,0.0352025579281 --0.269723434845,0.018499549715,-0.126877892144,0.0795768248736 --0.269723434845,0.018499549715,-0.126877892144,0.123951091819 --0.269723434845,0.018499549715,-0.126877892144,0.21269962571 --0.269723434845,0.018499549715,-0.126877892144,0.257073892656 --0.269723434845,0.018499549715,-0.126877892144,0.301448159602 --0.269723434845,0.018499549715,-0.126877892144,0.345822426547 --0.269723434845,0.018499549715,-0.126877892144,0.346266169217 --0.269723434845,0.018499549715,0.0737007551197,-0.452914378473 --0.269723434845,0.018499549715,0.0737007551197,-0.319791577637 --0.269723434845,0.018499549715,0.0737007551197,-0.275417310691 --0.269723434845,0.018499549715,0.0737007551197,-0.1866687768 --0.269723434845,0.018499549715,0.0737007551197,-0.142294509854 --0.269723434845,0.018499549715,0.0737007551197,-0.0979202429087 --0.269723434845,0.018499549715,0.0737007551197,-0.0535459759631 --0.269723434845,0.018499549715,0.0737007551197,0.0352025579281 --0.269723434845,0.018499549715,0.0737007551197,0.0795768248736 --0.269723434845,0.018499549715,0.0737007551197,0.123951091819 --0.269723434845,0.018499549715,0.0737007551197,0.21269962571 --0.269723434845,0.018499549715,0.0737007551197,0.257073892656 --0.269723434845,0.018499549715,0.0737007551197,0.301448159602 --0.269723434845,0.018499549715,0.0737007551197,0.345822426547 --0.269723434845,0.018499549715,0.0737007551197,0.346266169217 --0.269723434845,0.018499549715,0.474858049646,-0.452914378473 --0.269723434845,0.018499549715,0.474858049646,-0.364165844582 --0.269723434845,0.018499549715,0.474858049646,-0.319791577637 --0.269723434845,0.018499549715,0.474858049646,-0.275417310691 --0.269723434845,0.018499549715,0.474858049646,-0.1866687768 --0.269723434845,0.018499549715,0.474858049646,-0.142294509854 --0.269723434845,0.018499549715,0.474858049646,-0.0979202429087 --0.269723434845,0.018499549715,0.474858049646,-0.0535459759631 --0.269723434845,0.018499549715,0.474858049646,0.0352025579281 --0.269723434845,0.018499549715,0.474858049646,0.0795768248736 --0.269723434845,0.018499549715,0.474858049646,0.123951091819 --0.269723434845,0.018499549715,0.474858049646,0.21269962571 --0.269723434845,0.018499549715,0.474858049646,0.257073892656 --0.269723434845,0.018499549715,0.474858049646,0.301448159602 --0.269723434845,0.018499549715,0.474858049646,0.345822426547 --0.269723434845,0.018499549715,0.474858049646,0.346266169217 -0.369621003307,-0.141336559823,-0.314920373953,0.257073892656 -0.369621003307,-0.141336559823,-0.302384208499,-0.1866687768 -0.369621003307,-0.141336559823,-0.302384208499,0.0352025579281 -0.369621003307,-0.141336559823,-0.302384208499,0.0795768248736 -0.369621003307,-0.141336559823,-0.302384208499,0.21269962571 -0.369621003307,-0.141336559823,-0.302384208499,0.345822426547 -0.369621003307,-0.141336559823,-0.277311877591,-0.452914378473 -0.369621003307,-0.141336559823,-0.277311877591,-0.1866687768 -0.369621003307,-0.141336559823,-0.277311877591,-0.142294509854 -0.369621003307,-0.141336559823,-0.277311877591,-0.0979202429087 -0.369621003307,-0.141336559823,-0.277311877591,-0.0535459759631 -0.369621003307,-0.141336559823,-0.277311877591,0.0352025579281 -0.369621003307,-0.141336559823,-0.277311877591,0.123951091819 -0.369621003307,-0.141336559823,-0.277311877591,0.21269962571 -0.369621003307,-0.141336559823,-0.277311877591,0.257073892656 -0.369621003307,-0.141336559823,-0.277311877591,0.301448159602 -0.369621003307,-0.141336559823,-0.277311877591,0.345822426547 -0.369621003307,-0.141336559823,-0.227167215775,-0.452914378473 -0.369621003307,-0.141336559823,-0.227167215775,-0.364165844582 -0.369621003307,-0.141336559823,-0.227167215775,-0.319791577637 -0.369621003307,-0.141336559823,-0.227167215775,-0.275417310691 -0.369621003307,-0.141336559823,-0.227167215775,-0.1866687768 -0.369621003307,-0.141336559823,-0.227167215775,-0.0979202429087 -0.369621003307,-0.141336559823,-0.227167215775,-0.0535459759631 -0.369621003307,-0.141336559823,-0.227167215775,0.0352025579281 -0.369621003307,-0.141336559823,-0.227167215775,0.0795768248736 -0.369621003307,-0.141336559823,-0.227167215775,0.123951091819 -0.369621003307,-0.141336559823,-0.227167215775,0.21269962571 -0.369621003307,-0.141336559823,-0.227167215775,0.257073892656 -0.369621003307,-0.141336559823,-0.227167215775,0.345822426547 -0.369621003307,-0.141336559823,-0.227167215775,0.346266169217 -0.369621003307,-0.141336559823,-0.126877892144,-0.452914378473 -0.369621003307,-0.141336559823,-0.126877892144,-0.364165844582 -0.369621003307,-0.141336559823,-0.126877892144,-0.319791577637 -0.369621003307,-0.141336559823,-0.126877892144,-0.275417310691 -0.369621003307,-0.141336559823,-0.126877892144,-0.1866687768 -0.369621003307,-0.141336559823,-0.126877892144,-0.142294509854 -0.369621003307,-0.141336559823,-0.126877892144,-0.0979202429087 -0.369621003307,-0.141336559823,-0.126877892144,-0.0535459759631 -0.369621003307,-0.141336559823,-0.126877892144,0.0795768248736 -0.369621003307,-0.141336559823,-0.126877892144,0.123951091819 -0.369621003307,-0.141336559823,-0.126877892144,0.21269962571 -0.369621003307,-0.141336559823,-0.126877892144,0.257073892656 -0.369621003307,-0.141336559823,-0.126877892144,0.301448159602 -0.369621003307,-0.141336559823,-0.126877892144,0.345822426547 -0.369621003307,-0.141336559823,-0.126877892144,0.346266169217 -0.369621003307,-0.141336559823,0.0737007551197,-0.452914378473 -0.369621003307,-0.141336559823,0.0737007551197,-0.364165844582 -0.369621003307,-0.141336559823,0.0737007551197,-0.319791577637 -0.369621003307,-0.141336559823,0.0737007551197,-0.275417310691 -0.369621003307,-0.141336559823,0.0737007551197,-0.1866687768 -0.369621003307,-0.141336559823,0.0737007551197,-0.142294509854 -0.369621003307,-0.141336559823,0.0737007551197,-0.0979202429087 -0.369621003307,-0.141336559823,0.0737007551197,-0.0535459759631 -0.369621003307,-0.141336559823,0.0737007551197,0.0352025579281 -0.369621003307,-0.141336559823,0.0737007551197,0.0795768248736 -0.369621003307,-0.141336559823,0.0737007551197,0.123951091819 -0.369621003307,-0.141336559823,0.0737007551197,0.21269962571 -0.369621003307,-0.141336559823,0.0737007551197,0.257073892656 -0.369621003307,-0.141336559823,0.0737007551197,0.301448159602 -0.369621003307,-0.141336559823,0.0737007551197,0.345822426547 -0.369621003307,-0.141336559823,0.0737007551197,0.346266169217 -0.369621003307,-0.141336559823,0.474858049646,-0.364165844582 -0.369621003307,-0.141336559823,0.474858049646,-0.319791577637 -0.369621003307,-0.141336559823,0.474858049646,-0.275417310691 -0.369621003307,-0.141336559823,0.474858049646,-0.1866687768 -0.369621003307,-0.141336559823,0.474858049646,-0.142294509854 -0.369621003307,-0.141336559823,0.474858049646,-0.0979202429087 -0.369621003307,-0.141336559823,0.474858049646,-0.0535459759631 -0.369621003307,-0.141336559823,0.474858049646,0.0352025579281 -0.369621003307,-0.141336559823,0.474858049646,0.0795768248736 -0.369621003307,-0.141336559823,0.474858049646,0.123951091819 -0.369621003307,-0.141336559823,0.474858049646,0.21269962571 -0.369621003307,-0.141336559823,0.474858049646,0.257073892656 -0.369621003307,-0.141336559823,0.474858049646,0.301448159602 -0.369621003307,-0.141336559823,0.474858049646,0.345822426547 -0.369621003307,0.018499549715,-0.32118845668,-0.452914378473 -0.369621003307,0.018499549715,-0.32118845668,-0.1866687768 -0.369621003307,0.018499549715,-0.314920373953,0.0795768248736 -0.369621003307,0.018499549715,-0.302384208499,-0.0535459759631 -0.369621003307,0.018499549715,-0.302384208499,0.0795768248736 -0.369621003307,0.018499549715,-0.277311877591,-0.452914378473 -0.369621003307,0.018499549715,-0.277311877591,-0.1866687768 -0.369621003307,0.018499549715,-0.277311877591,-0.142294509854 -0.369621003307,0.018499549715,-0.277311877591,-0.0979202429087 -0.369621003307,0.018499549715,-0.277311877591,0.0795768248736 -0.369621003307,0.018499549715,-0.277311877591,0.123951091819 -0.369621003307,0.018499549715,-0.277311877591,0.301448159602 -0.369621003307,0.018499549715,-0.227167215775,-0.452914378473 -0.369621003307,0.018499549715,-0.227167215775,-0.364165844582 -0.369621003307,0.018499549715,-0.227167215775,-0.319791577637 -0.369621003307,0.018499549715,-0.227167215775,-0.275417310691 -0.369621003307,0.018499549715,-0.227167215775,-0.1866687768 -0.369621003307,0.018499549715,-0.227167215775,-0.142294509854 -0.369621003307,0.018499549715,-0.227167215775,-0.0979202429087 -0.369621003307,0.018499549715,-0.227167215775,0.0352025579281 -0.369621003307,0.018499549715,-0.227167215775,0.0795768248736 -0.369621003307,0.018499549715,-0.227167215775,0.123951091819 -0.369621003307,0.018499549715,-0.227167215775,0.257073892656 -0.369621003307,0.018499549715,-0.227167215775,0.301448159602 -0.369621003307,0.018499549715,-0.227167215775,0.345822426547 -0.369621003307,0.018499549715,-0.227167215775,0.346266169217 -0.369621003307,0.018499549715,-0.126877892144,-0.452914378473 -0.369621003307,0.018499549715,-0.126877892144,-0.364165844582 -0.369621003307,0.018499549715,-0.126877892144,-0.319791577637 -0.369621003307,0.018499549715,-0.126877892144,-0.275417310691 -0.369621003307,0.018499549715,-0.126877892144,-0.1866687768 -0.369621003307,0.018499549715,-0.126877892144,-0.142294509854 -0.369621003307,0.018499549715,-0.126877892144,-0.0979202429087 -0.369621003307,0.018499549715,-0.126877892144,-0.0535459759631 -0.369621003307,0.018499549715,-0.126877892144,0.0352025579281 -0.369621003307,0.018499549715,-0.126877892144,0.0795768248736 -0.369621003307,0.018499549715,-0.126877892144,0.123951091819 -0.369621003307,0.018499549715,-0.126877892144,0.21269962571 -0.369621003307,0.018499549715,-0.126877892144,0.257073892656 -0.369621003307,0.018499549715,-0.126877892144,0.301448159602 -0.369621003307,0.018499549715,-0.126877892144,0.345822426547 -0.369621003307,0.018499549715,-0.126877892144,0.346266169217 -0.369621003307,0.018499549715,0.0737007551197,-0.452914378473 -0.369621003307,0.018499549715,0.0737007551197,-0.364165844582 -0.369621003307,0.018499549715,0.0737007551197,-0.319791577637 -0.369621003307,0.018499549715,0.0737007551197,-0.275417310691 -0.369621003307,0.018499549715,0.0737007551197,-0.1866687768 -0.369621003307,0.018499549715,0.0737007551197,-0.142294509854 -0.369621003307,0.018499549715,0.0737007551197,-0.0979202429087 -0.369621003307,0.018499549715,0.0737007551197,-0.0535459759631 -0.369621003307,0.018499549715,0.0737007551197,0.0352025579281 -0.369621003307,0.018499549715,0.0737007551197,0.0795768248736 -0.369621003307,0.018499549715,0.0737007551197,0.123951091819 -0.369621003307,0.018499549715,0.0737007551197,0.21269962571 -0.369621003307,0.018499549715,0.0737007551197,0.257073892656 -0.369621003307,0.018499549715,0.0737007551197,0.301448159602 -0.369621003307,0.018499549715,0.0737007551197,0.345822426547 -0.369621003307,0.018499549715,0.0737007551197,0.346266169217 -0.369621003307,0.018499549715,0.474858049646,-0.452914378473 -0.369621003307,0.018499549715,0.474858049646,-0.364165844582 -0.369621003307,0.018499549715,0.474858049646,-0.319791577637 -0.369621003307,0.018499549715,0.474858049646,-0.275417310691 -0.369621003307,0.018499549715,0.474858049646,-0.1866687768 -0.369621003307,0.018499549715,0.474858049646,-0.142294509854 -0.369621003307,0.018499549715,0.474858049646,-0.0979202429087 -0.369621003307,0.018499549715,0.474858049646,-0.0535459759631 -0.369621003307,0.018499549715,0.474858049646,0.0352025579281 -0.369621003307,0.018499549715,0.474858049646,0.0795768248736 -0.369621003307,0.018499549715,0.474858049646,0.123951091819 -0.369621003307,0.018499549715,0.474858049646,0.21269962571 -0.369621003307,0.018499549715,0.474858049646,0.257073892656 -0.369621003307,0.018499549715,0.474858049646,0.301448159602 -0.369621003307,0.018499549715,0.474858049646,0.345822426547 -0.369621003307,0.018499549715,0.474858049646,0.346266169217 -0.369621003307,0.657843987867,-0.314920373953,-0.142294509854 -0.369621003307,0.657843987867,-0.302384208499,-0.275417310691 -0.369621003307,0.657843987867,-0.227167215775,0.0352025579281 -0.369621003307,0.657843987867,-0.227167215775,0.0795768248736 -0.369621003307,0.657843987867,-0.227167215775,0.21269962571 -0.369621003307,0.657843987867,-0.227167215775,0.257073892656 -0.369621003307,0.657843987867,-0.227167215775,0.345822426547 -0.369621003307,0.657843987867,-0.126877892144,-0.1866687768 -0.369621003307,0.657843987867,-0.126877892144,-0.0979202429087 -0.369621003307,0.657843987867,-0.126877892144,0.0795768248736 -0.369621003307,0.657843987867,-0.126877892144,0.123951091819 -0.369621003307,0.657843987867,-0.126877892144,0.21269962571 -0.369621003307,0.657843987867,-0.126877892144,0.257073892656 -0.369621003307,0.657843987867,-0.126877892144,0.301448159602 -0.369621003307,0.657843987867,-0.126877892144,0.346266169217 -0.369621003307,0.657843987867,0.0737007551197,-0.364165844582 -0.369621003307,0.657843987867,0.0737007551197,-0.319791577637 -0.369621003307,0.657843987867,0.0737007551197,-0.275417310691 -0.369621003307,0.657843987867,0.0737007551197,-0.142294509854 -0.369621003307,0.657843987867,0.0737007551197,-0.0979202429087 -0.369621003307,0.657843987867,0.0737007551197,-0.0535459759631 -0.369621003307,0.657843987867,0.0737007551197,0.0352025579281 -0.369621003307,0.657843987867,0.0737007551197,0.0795768248736 -0.369621003307,0.657843987867,0.0737007551197,0.123951091819 -0.369621003307,0.657843987867,0.0737007551197,0.21269962571 -0.369621003307,0.657843987867,0.0737007551197,0.257073892656 -0.369621003307,0.657843987867,0.0737007551197,0.301448159602 -0.369621003307,0.657843987867,0.0737007551197,0.346266169217 -0.369621003307,0.657843987867,0.474858049646,-0.364165844582 -0.369621003307,0.657843987867,0.474858049646,-0.319791577637 -0.369621003307,0.657843987867,0.474858049646,-0.275417310691 -0.369621003307,0.657843987867,0.474858049646,-0.1866687768 -0.369621003307,0.657843987867,0.474858049646,-0.142294509854 -0.369621003307,0.657843987867,0.474858049646,-0.0979202429087 -0.369621003307,0.657843987867,0.474858049646,-0.0535459759631 -0.369621003307,0.657843987867,0.474858049646,0.0352025579281 -0.369621003307,0.657843987867,0.474858049646,0.0795768248736 -0.369621003307,0.657843987867,0.474858049646,0.123951091819 -0.369621003307,0.657843987867,0.474858049646,0.21269962571 -0.369621003307,0.657843987867,0.474858049646,0.257073892656 -0.369621003307,0.657843987867,0.474858049646,0.301448159602 -0.369621003307,0.657843987867,0.474858049646,0.345822426547 -54123792898.5 -121470858147 -3638106285000000 -1.60756296822E+016 -608968852347 -2109464220090 -1.95114323448E+016 -4.79511015336E+016 -71978621444.8 -171760606787 -213930254338000 -2260365986250000 -4952124766050 -12320033283100 -18142207372800 -23349208587600 -27139210849700 -45095480912600 -45959950912100 -51163249783600 -42594030297100 -50460588023300 -117020581223000 -124276974592000 -135657389827000 -134058184922000 -155909903633000 -158623679039000 -149101586975000 -170110125803000 -189379130153000 -202649417664000 -211606038624000 -192221177785000 -310890509435000 -343863284608000 -325678957772000 -430809541156000 -509621237708000 -423033880026000 -587071910573000 -680623907917000 -744742195421000 -795203232880000 -936678892190000 -881246682507000 -942993570599000 -955993905096000 -860542692784000 -1039364661380000 -1245405462050000 -1297388336310000 -1370245414670000 -1663128355590000 -1814361376710000 -2105318599640000 -2100298307320000 -2599649103740000 -2578738300900000 -3025342943800000 -3135923494500000 -3564861626750000 -3570025096130000 -3686213190440000 -4669723123710000 -4684898895170000 -4826719683910000 -5389749756370000 -6044534351550000 -6851325747950000 -7734567028680000 -7779297080670000 -9.30286332418E+015 -1.00926858565E+016 -1.05522151095E+016 -1.21982910604E+016 -1.2609992587E+016 -1.33405755608E+016 -1.42671665485E+016 -4285579243840 -16084877279900 -13277413905400 -17174788896100 -28180447438100 -32138189428900 -33160385962500 -36238363635100 -38751306559100 -48268216906400 -82569478769100 -92601210196700 -106956785402000 -113490453007000 -127675249201000 -131124594596000 -128763881757000 -141227807849000 -121464378127000 -143027796318000 -137027644341000 -289027586148000 -296147332944000 -303981082985000 -336882250985000 -366369655254000 -351465670160000 -363887455886000 -385379497093000 -389405201045000 -426642309866000 -383576600737000 -403423009896000 -466777994043000 -393024969784000 -1.07529193278E+015 -1212290395850000 -1360495959340000 -1267032305850000 -1579946207100000 -1682730063730000 -1837083159410000 -1952434534600000 -2258066181040000 -2199017638930000 -2369976083480000 -2508934799420000 -2615627160430000 -2467736541880000 -2311519439160000 -2512342637980000 -4821893659190000 -5211870731540000 -5108186953080000 -5880905088600000 -6409003486990000 -7212228267580000 -7301329218060000 -8120246131829999 -8917162511430000 -9.44600159965E+015 -9.92519305348E+015 -1.06847967479E+016 -1.11602461031E+016 -1.16605949281E+016 -1.2404906342E+016 -1.47082922807E+016 -1.9334186207E+016 -2.13511675373E+016 -2.14548308013E+016 -2.2859694152E+016 -2.59389616184E+016 -2.87801886438E+016 -2.78806945582E+016 -3.01488266172E+016 -3.64364012616E+016 -3.25456520238E+016 -3.47706674567E+016 -4.17357684136E+016 -4.28330927938E+016 -4.61746688249E+016 -4.68746738207E+016 -5.86310092028E+016 -161313172246 -6146526348210 -7100908376540 -8894783132820 -9759943236600 -21423689301300 -29089817483500 -34093380254800 -35164311442600 -43848080490600 -53886899790600 -67874183459300 -106021835044000 -77891036339500 -99061284120300 -100403765820000 -93645420902800 -144469815731000 -179151679296000 -160491636495000 -194372691490000 -217725481323000 -264204514987000 -273939300389000 -284658524669000 -290171264538000 -297842220440000 -349831569845000 -353265521656000 -308013338658000 -386805934395000 -604122205000000 -722717949023000 -749850832551000 -824653093717000 -941936090972000 -1008413510510000 -1.08548059417E+015 -1.09829839811E+015 -1462322494640000 -1586488666570000 -1726228067520000 -1923715305150000 -1419911971280000 -1716396258210000 -1684446185460000 -1451929761320000 -2376387855790000 -2649902169240000 -3066230645040000 -3726146925770000 -4030518397640000 -4059079175860000 -4500661601090000 -5772453637770000 -6007838111710000 -6815348851990000 -7616939522400000 -8312821381450000 -8738898800779999 -9.11630169607E+015 -1.09835614115E+016 -8343780006159999 -1.08306165432E+016 -1.24988238013E+016 -1.3468271848E+016 -1.59065184514E+016 -1.75313776237E+016 -1.76683606367E+016 -1.9866608854E+016 -2.55440361956E+016 -2.5635755578E+016 -2.68937730675E+016 -3.1368597008E+016 -3.39406468359E+016 -3.79073721256E+016 -3.71035574968E+016 -4.73307069277E+016 -14548576521000 -22617940609900 -30416035115500 -24369589167900 -25521710913900 -26256508403600 -70613243515300 -75711163713700 -88667662560800 -78846150858700 -101304530408000 -73820439039100 -86134451492900 -97120102547600 -107937470928000 -76772646861400 -95768123137600 -259824500199000 -259036048936000 -317361440008000 -280161847991000 -357554600763000 -354835053285000 -334707061497000 -296837869770000 -356701295781000 -355796792955000 -435834817407000 -348390160037000 -570792101029000 -441676120624000 -1243375266240000 -1.07168673783E+015 -1338815069960000 -1335943361720000 -1409272934510000 -1293485118490000 -1441102243750000 -1699362645320000 -1958946332550000 -1993752638680000 -1714871826870000 -1644847813380000 -2040549880390000 -1.95324833727E+015 -1835901040890000 -4077632427900000 -4889358610380000 -4697639417870000 -5135152422500000 -5000526808520000 -5831774490310000 -5605058618770000 -5824399422830000 -6364100327060000 -6532097085870000 -7046024070610000 -7058208648170000 -8823823172159999 -8565404304579999 -7429792866730000 -8135844935040000 -2.10475722875E+016 -1.71297623448E+016 -2.17527304455E+016 -2.62743616984E+016 -2.0605339779E+016 -2.45471732842E+016 -2.66092897977E+016 -3.23551690226E+016 -2.46590658581E+016 -2.93431136321E+016 -3.70602446674E+016 -3.96026518214E+016 -3.68405194831E+016 -4.41958125837E+016 -1756374854070 -2556174983140 -8111595952740 -19832031992500 -11140556807000 -40621373640000 -63844995591500 -58316526435100 -49282223580700 -57328401189200 -51861080687500 -55613140260100 -132176990525000 -200313850588000 -174859753820000 -187684112868000 -190568512012000 -238351890972000 -185145019845000 -262597022284000 -233368141744000 -292675777437000 -305566175200000 -247592610994000 -314860222428000 -286685200916000 -740023584612000 -686988468141000 -695786792995000 -816213001296000 -915602863083000 -878027958723000 -888582874165000 -974544517036000 -868889259897000 -1182941925080000 -963103253627000 -1262014020880000 -1146522461310000 -1386542698880000 -1198601438000000 -1314124018070000 -2725958694180000 -2475524399380000 -3041646727840000 -3292886381200000 -3700247028600000 -3161457499880000 -3898961472050000 -3698701351470000 -4407324534340000 -4.08190725049E+015 -4186550068870000 -3926453399800000 -5392945300410000 -4435321286360000 -5047417285370000 -5054628605600000 -1.3109495594E+016 -1.09403912425E+016 -9.99676438926E+015 -1.0767202472E+016 -1.43210146701E+016 -1.35894311704E+016 -1.3422289038E+016 -1.27240570228E+016 -1.97166329127E+016 -1.75182168132E+016 -1.85349216508E+016 -1.91821683896E+016 -2.03133755825E+016 -1.81906352935E+016 -2.29978882342E+016 -2.00913447742E+016 -988956603493 -3553603079600 -62958418004000 -59400524191400 -83407450316900 -65572677829700 -84364531918100 -72480150655100 -91424775022100 -204977960789000 -112276529053000 -270065974142000 -208000523684000 -226507716826000 -278686789834000 -203510820353000 -224510263726000 -186154630320000 -239667454588000 -408940190264000 -447587807344000 -412428554779000 -395727033684000 -371527732444000 -468010465514000 -553990494377000 -535098907444000 -654773728324000 -978214755119000 -797892944175000 -895482127406000 -1195840287340000 -723687815191000 -1532191746940000 -1915578681090000 -1594102374250000 -1493104126630000 -736986471019000 -1519998138570000 -2414228080600000 -1435918033030000 -1561546945390000 --0.429559544383,-0.141336559823,-0.324322498044,-0.364165844582 --0.429559544383,-0.141336559823,-0.324322498044,-0.319791577637 --0.429559544383,-0.141336559823,-0.324322498044,-0.275417310691 --0.429559544383,-0.141336559823,-0.324322498044,-0.1866687768 --0.429559544383,-0.141336559823,-0.324322498044,-0.142294509854 --0.429559544383,-0.141336559823,-0.324322498044,-0.0979202429087 --0.429559544383,-0.141336559823,-0.324322498044,-0.0535459759631 --0.429559544383,-0.141336559823,-0.324322498044,0.0352025579281 --0.429559544383,-0.141336559823,-0.324322498044,0.0795768248736 --0.429559544383,-0.141336559823,-0.324322498044,0.123951091819 --0.429559544383,-0.141336559823,-0.324322498044,0.21269962571 --0.429559544383,-0.141336559823,-0.324322498044,0.257073892656 --0.429559544383,-0.141336559823,-0.324322498044,0.301448159602 --0.429559544383,-0.141336559823,-0.324322498044,0.345822426547 --0.429559544383,-0.141336559823,-0.32118845668,-0.452914378473 --0.429559544383,-0.141336559823,-0.32118845668,-0.364165844582 --0.429559544383,-0.141336559823,-0.32118845668,-0.319791577637 --0.429559544383,-0.141336559823,-0.32118845668,-0.275417310691 --0.429559544383,-0.141336559823,-0.32118845668,-0.1866687768 --0.429559544383,-0.141336559823,-0.32118845668,-0.142294509854 --0.429559544383,-0.141336559823,-0.32118845668,-0.0979202429087 --0.429559544383,-0.141336559823,-0.32118845668,-0.0535459759631 --0.429559544383,-0.141336559823,-0.32118845668,0.0352025579281 --0.429559544383,-0.141336559823,-0.32118845668,0.0795768248736 --0.429559544383,-0.141336559823,-0.32118845668,0.123951091819 --0.429559544383,-0.141336559823,-0.32118845668,0.21269962571 --0.429559544383,-0.141336559823,-0.32118845668,0.257073892656 --0.429559544383,-0.141336559823,-0.32118845668,0.301448159602 --0.429559544383,-0.141336559823,-0.32118845668,0.345822426547 --0.429559544383,-0.141336559823,-0.32118845668,0.346266169217 --0.429559544383,-0.141336559823,-0.314920373953,-0.452914378473 --0.429559544383,-0.141336559823,-0.314920373953,-0.364165844582 --0.429559544383,-0.141336559823,-0.314920373953,-0.319791577637 --0.429559544383,-0.141336559823,-0.314920373953,-0.275417310691 --0.429559544383,-0.141336559823,-0.314920373953,-0.1866687768 --0.429559544383,-0.141336559823,-0.314920373953,-0.142294509854 --0.429559544383,-0.141336559823,-0.314920373953,-0.0979202429087 --0.429559544383,-0.141336559823,-0.314920373953,-0.0535459759631 --0.429559544383,-0.141336559823,-0.314920373953,0.0352025579281 --0.429559544383,-0.141336559823,-0.314920373953,0.0795768248736 --0.429559544383,-0.141336559823,-0.314920373953,0.123951091819 --0.429559544383,-0.141336559823,-0.314920373953,0.21269962571 --0.429559544383,-0.141336559823,-0.314920373953,0.257073892656 --0.429559544383,-0.141336559823,-0.314920373953,0.301448159602 --0.429559544383,-0.141336559823,-0.314920373953,0.345822426547 --0.429559544383,-0.141336559823,-0.314920373953,0.346266169217 --0.429559544383,-0.141336559823,-0.302384208499,-0.364165844582 --0.429559544383,-0.141336559823,-0.302384208499,-0.319791577637 --0.429559544383,-0.141336559823,-0.302384208499,-0.275417310691 --0.429559544383,-0.141336559823,-0.302384208499,-0.1866687768 --0.429559544383,-0.141336559823,-0.302384208499,-0.142294509854 --0.429559544383,-0.141336559823,-0.302384208499,-0.0979202429087 --0.429559544383,-0.141336559823,-0.302384208499,-0.0535459759631 --0.429559544383,-0.141336559823,-0.302384208499,0.0352025579281 --0.429559544383,-0.141336559823,-0.302384208499,0.0795768248736 --0.429559544383,-0.141336559823,-0.302384208499,0.123951091819 --0.429559544383,-0.141336559823,-0.302384208499,0.257073892656 --0.429559544383,-0.141336559823,-0.302384208499,0.301448159602 --0.429559544383,-0.141336559823,-0.302384208499,0.345822426547 --0.429559544383,-0.141336559823,-0.302384208499,0.346266169217 --0.429559544383,-0.141336559823,-0.277311877591,-0.319791577637 --0.429559544383,-0.141336559823,-0.277311877591,-0.1866687768 --0.429559544383,-0.141336559823,-0.277311877591,-0.142294509854 --0.429559544383,-0.141336559823,-0.277311877591,-0.0979202429087 --0.429559544383,-0.141336559823,-0.277311877591,-0.0535459759631 --0.429559544383,-0.141336559823,-0.277311877591,0.0352025579281 --0.429559544383,-0.141336559823,-0.277311877591,0.257073892656 --0.429559544383,-0.141336559823,-0.277311877591,0.301448159602 --0.429559544383,-0.141336559823,-0.227167215775,-0.452914378473 --0.429559544383,-0.141336559823,-0.227167215775,-0.364165844582 --0.429559544383,-0.141336559823,-0.227167215775,-0.319791577637 --0.429559544383,-0.141336559823,-0.227167215775,-0.275417310691 --0.429559544383,-0.141336559823,-0.126877892144,-0.452914378473 --0.269723434845,-0.141336559823,-0.324322498044,-0.452914378473 --0.269723434845,-0.141336559823,-0.324322498044,-0.364165844582 --0.269723434845,-0.141336559823,-0.324322498044,-0.319791577637 --0.269723434845,-0.141336559823,-0.324322498044,-0.275417310691 --0.269723434845,-0.141336559823,-0.324322498044,-0.1866687768 --0.269723434845,-0.141336559823,-0.324322498044,-0.142294509854 --0.269723434845,-0.141336559823,-0.324322498044,-0.0979202429087 --0.269723434845,-0.141336559823,-0.324322498044,-0.0535459759631 --0.269723434845,-0.141336559823,-0.324322498044,0.0352025579281 --0.269723434845,-0.141336559823,-0.324322498044,0.0795768248736 --0.269723434845,-0.141336559823,-0.324322498044,0.123951091819 --0.269723434845,-0.141336559823,-0.324322498044,0.21269962571 --0.269723434845,-0.141336559823,-0.324322498044,0.257073892656 --0.269723434845,-0.141336559823,-0.324322498044,0.301448159602 --0.269723434845,-0.141336559823,-0.324322498044,0.345822426547 --0.269723434845,-0.141336559823,-0.324322498044,0.346266169217 --0.269723434845,-0.141336559823,-0.32118845668,-0.452914378473 --0.269723434845,-0.141336559823,-0.32118845668,-0.364165844582 --0.269723434845,-0.141336559823,-0.32118845668,-0.319791577637 --0.269723434845,-0.141336559823,-0.32118845668,-0.275417310691 --0.269723434845,-0.141336559823,-0.32118845668,-0.1866687768 --0.269723434845,-0.141336559823,-0.32118845668,-0.142294509854 --0.269723434845,-0.141336559823,-0.32118845668,-0.0979202429087 --0.269723434845,-0.141336559823,-0.32118845668,-0.0535459759631 --0.269723434845,-0.141336559823,-0.32118845668,0.0352025579281 --0.269723434845,-0.141336559823,-0.32118845668,0.0795768248736 --0.269723434845,-0.141336559823,-0.32118845668,0.123951091819 --0.269723434845,-0.141336559823,-0.32118845668,0.257073892656 --0.269723434845,-0.141336559823,-0.32118845668,0.301448159602 --0.269723434845,-0.141336559823,-0.32118845668,0.345822426547 --0.269723434845,-0.141336559823,-0.32118845668,0.346266169217 --0.269723434845,-0.141336559823,-0.314920373953,-0.452914378473 --0.269723434845,-0.141336559823,-0.314920373953,-0.364165844582 --0.269723434845,-0.141336559823,-0.314920373953,-0.319791577637 --0.269723434845,-0.141336559823,-0.314920373953,-0.275417310691 --0.269723434845,-0.141336559823,-0.314920373953,-0.1866687768 --0.269723434845,-0.141336559823,-0.314920373953,-0.142294509854 --0.269723434845,-0.141336559823,-0.314920373953,-0.0979202429087 --0.269723434845,-0.141336559823,-0.314920373953,-0.0535459759631 --0.269723434845,-0.141336559823,-0.314920373953,0.123951091819 --0.269723434845,-0.141336559823,-0.314920373953,0.21269962571 --0.269723434845,-0.141336559823,-0.314920373953,0.257073892656 --0.269723434845,-0.141336559823,-0.314920373953,0.345822426547 --0.269723434845,-0.141336559823,-0.314920373953,0.346266169217 --0.269723434845,-0.141336559823,-0.302384208499,-0.452914378473 --0.269723434845,-0.141336559823,-0.302384208499,-0.319791577637 --0.269723434845,-0.141336559823,-0.302384208499,-0.142294509854 --0.269723434845,-0.141336559823,-0.302384208499,-0.0535459759631 --0.269723434845,-0.141336559823,-0.302384208499,0.0352025579281 --0.269723434845,-0.141336559823,-0.302384208499,0.123951091819 --0.269723434845,-0.141336559823,-0.302384208499,0.21269962571 --0.269723434845,-0.141336559823,-0.302384208499,0.257073892656 --0.269723434845,-0.141336559823,-0.302384208499,0.345822426547 --0.269723434845,-0.141336559823,-0.302384208499,0.346266169217 --0.269723434845,-0.141336559823,-0.277311877591,-0.364165844582 --0.269723434845,-0.141336559823,-0.277311877591,-0.319791577637 --0.269723434845,-0.141336559823,-0.277311877591,-0.1866687768 --0.269723434845,-0.141336559823,-0.277311877591,-0.0535459759631 --0.269723434845,-0.141336559823,-0.277311877591,0.301448159602 --0.269723434845,-0.141336559823,-0.227167215775,-0.1866687768 --0.269723434845,-0.141336559823,-0.227167215775,-0.142294509854 --0.269723434845,0.018499549715,-0.324322498044,-0.364165844582 --0.269723434845,0.018499549715,-0.324322498044,-0.319791577637 --0.269723434845,0.018499549715,-0.324322498044,-0.275417310691 --0.269723434845,0.018499549715,-0.324322498044,-0.1866687768 --0.269723434845,0.018499549715,-0.324322498044,-0.142294509854 --0.269723434845,0.018499549715,-0.324322498044,-0.0979202429087 --0.269723434845,0.018499549715,-0.324322498044,-0.0535459759631 --0.269723434845,0.018499549715,-0.324322498044,0.0352025579281 --0.269723434845,0.018499549715,-0.324322498044,0.0795768248736 --0.269723434845,0.018499549715,-0.324322498044,0.123951091819 --0.269723434845,0.018499549715,-0.324322498044,0.21269962571 --0.269723434845,0.018499549715,-0.324322498044,0.257073892656 --0.269723434845,0.018499549715,-0.324322498044,0.301448159602 --0.269723434845,0.018499549715,-0.324322498044,0.345822426547 --0.269723434845,0.018499549715,-0.324322498044,0.346266169217 --0.269723434845,0.018499549715,-0.32118845668,-0.452914378473 --0.269723434845,0.018499549715,-0.32118845668,-0.364165844582 --0.269723434845,0.018499549715,-0.32118845668,-0.319791577637 --0.269723434845,0.018499549715,-0.32118845668,-0.275417310691 --0.269723434845,0.018499549715,-0.32118845668,-0.1866687768 --0.269723434845,0.018499549715,-0.32118845668,-0.142294509854 --0.269723434845,0.018499549715,-0.32118845668,-0.0979202429087 --0.269723434845,0.018499549715,-0.32118845668,-0.0535459759631 --0.269723434845,0.018499549715,-0.32118845668,0.0352025579281 --0.269723434845,0.018499549715,-0.32118845668,0.0795768248736 --0.269723434845,0.018499549715,-0.32118845668,0.123951091819 --0.269723434845,0.018499549715,-0.32118845668,0.21269962571 --0.269723434845,0.018499549715,-0.32118845668,0.257073892656 --0.269723434845,0.018499549715,-0.32118845668,0.301448159602 --0.269723434845,0.018499549715,-0.32118845668,0.345822426547 --0.269723434845,0.018499549715,-0.32118845668,0.346266169217 --0.269723434845,0.018499549715,-0.314920373953,-0.452914378473 --0.269723434845,0.018499549715,-0.314920373953,-0.364165844582 --0.269723434845,0.018499549715,-0.314920373953,-0.319791577637 --0.269723434845,0.018499549715,-0.314920373953,-0.275417310691 --0.269723434845,0.018499549715,-0.314920373953,-0.1866687768 --0.269723434845,0.018499549715,-0.314920373953,-0.142294509854 --0.269723434845,0.018499549715,-0.314920373953,-0.0979202429087 --0.269723434845,0.018499549715,-0.314920373953,-0.0535459759631 --0.269723434845,0.018499549715,-0.314920373953,0.0352025579281 --0.269723434845,0.018499549715,-0.314920373953,0.123951091819 --0.269723434845,0.018499549715,-0.314920373953,0.21269962571 --0.269723434845,0.018499549715,-0.314920373953,0.257073892656 --0.269723434845,0.018499549715,-0.314920373953,0.345822426547 --0.269723434845,0.018499549715,-0.302384208499,-0.364165844582 --0.269723434845,0.018499549715,-0.302384208499,-0.319791577637 --0.269723434845,0.018499549715,-0.302384208499,-0.275417310691 --0.269723434845,0.018499549715,-0.302384208499,-0.1866687768 --0.269723434845,0.018499549715,-0.302384208499,-0.142294509854 --0.269723434845,0.018499549715,-0.302384208499,-0.0979202429087 --0.269723434845,0.018499549715,-0.302384208499,-0.0535459759631 --0.269723434845,0.018499549715,-0.302384208499,0.0352025579281 --0.269723434845,0.018499549715,-0.302384208499,0.123951091819 --0.269723434845,0.018499549715,-0.302384208499,0.257073892656 --0.269723434845,0.018499549715,-0.302384208499,0.301448159602 --0.269723434845,0.018499549715,-0.302384208499,0.346266169217 --0.269723434845,0.018499549715,-0.277311877591,-0.319791577637 --0.269723434845,0.018499549715,-0.277311877591,-0.1866687768 --0.269723434845,0.018499549715,-0.277311877591,-0.142294509854 --0.269723434845,0.018499549715,-0.277311877591,-0.0535459759631 --0.269723434845,0.018499549715,-0.277311877591,0.0352025579281 --0.269723434845,0.018499549715,-0.277311877591,0.257073892656 --0.269723434845,0.018499549715,-0.277311877591,0.346266169217 --0.269723434845,0.018499549715,-0.227167215775,0.123951091819 --0.269723434845,0.018499549715,-0.227167215775,0.21269962571 --0.269723434845,0.018499549715,0.0737007551197,-0.364165844582 -0.369621003307,-0.141336559823,-0.324322498044,-0.364165844582 -0.369621003307,-0.141336559823,-0.324322498044,-0.319791577637 -0.369621003307,-0.141336559823,-0.324322498044,-0.275417310691 -0.369621003307,-0.141336559823,-0.324322498044,-0.1866687768 -0.369621003307,-0.141336559823,-0.324322498044,-0.142294509854 -0.369621003307,-0.141336559823,-0.324322498044,-0.0979202429087 -0.369621003307,-0.141336559823,-0.324322498044,-0.0535459759631 -0.369621003307,-0.141336559823,-0.324322498044,0.0352025579281 -0.369621003307,-0.141336559823,-0.324322498044,0.0795768248736 -0.369621003307,-0.141336559823,-0.324322498044,0.123951091819 -0.369621003307,-0.141336559823,-0.324322498044,0.21269962571 -0.369621003307,-0.141336559823,-0.324322498044,0.257073892656 -0.369621003307,-0.141336559823,-0.324322498044,0.301448159602 -0.369621003307,-0.141336559823,-0.324322498044,0.345822426547 -0.369621003307,-0.141336559823,-0.32118845668,-0.452914378473 -0.369621003307,-0.141336559823,-0.32118845668,-0.364165844582 -0.369621003307,-0.141336559823,-0.32118845668,-0.319791577637 -0.369621003307,-0.141336559823,-0.32118845668,-0.275417310691 -0.369621003307,-0.141336559823,-0.32118845668,-0.1866687768 -0.369621003307,-0.141336559823,-0.32118845668,-0.142294509854 -0.369621003307,-0.141336559823,-0.32118845668,-0.0979202429087 -0.369621003307,-0.141336559823,-0.32118845668,-0.0535459759631 -0.369621003307,-0.141336559823,-0.32118845668,0.0352025579281 -0.369621003307,-0.141336559823,-0.32118845668,0.0795768248736 -0.369621003307,-0.141336559823,-0.32118845668,0.123951091819 -0.369621003307,-0.141336559823,-0.32118845668,0.21269962571 -0.369621003307,-0.141336559823,-0.32118845668,0.257073892656 -0.369621003307,-0.141336559823,-0.32118845668,0.301448159602 -0.369621003307,-0.141336559823,-0.32118845668,0.345822426547 -0.369621003307,-0.141336559823,-0.32118845668,0.346266169217 -0.369621003307,-0.141336559823,-0.314920373953,-0.452914378473 -0.369621003307,-0.141336559823,-0.314920373953,-0.364165844582 -0.369621003307,-0.141336559823,-0.314920373953,-0.319791577637 -0.369621003307,-0.141336559823,-0.314920373953,-0.275417310691 -0.369621003307,-0.141336559823,-0.314920373953,-0.1866687768 -0.369621003307,-0.141336559823,-0.314920373953,-0.142294509854 -0.369621003307,-0.141336559823,-0.314920373953,-0.0979202429087 -0.369621003307,-0.141336559823,-0.314920373953,-0.0535459759631 -0.369621003307,-0.141336559823,-0.314920373953,0.0352025579281 -0.369621003307,-0.141336559823,-0.314920373953,0.0795768248736 -0.369621003307,-0.141336559823,-0.314920373953,0.123951091819 -0.369621003307,-0.141336559823,-0.314920373953,0.21269962571 -0.369621003307,-0.141336559823,-0.314920373953,0.301448159602 -0.369621003307,-0.141336559823,-0.314920373953,0.345822426547 -0.369621003307,-0.141336559823,-0.314920373953,0.346266169217 -0.369621003307,-0.141336559823,-0.302384208499,-0.452914378473 -0.369621003307,-0.141336559823,-0.302384208499,-0.364165844582 -0.369621003307,-0.141336559823,-0.302384208499,-0.319791577637 -0.369621003307,-0.141336559823,-0.302384208499,-0.275417310691 -0.369621003307,-0.141336559823,-0.302384208499,-0.142294509854 -0.369621003307,-0.141336559823,-0.302384208499,-0.0979202429087 -0.369621003307,-0.141336559823,-0.302384208499,-0.0535459759631 -0.369621003307,-0.141336559823,-0.302384208499,0.123951091819 -0.369621003307,-0.141336559823,-0.302384208499,0.257073892656 -0.369621003307,-0.141336559823,-0.302384208499,0.301448159602 -0.369621003307,-0.141336559823,-0.302384208499,0.346266169217 -0.369621003307,-0.141336559823,-0.277311877591,-0.364165844582 -0.369621003307,-0.141336559823,-0.277311877591,-0.319791577637 -0.369621003307,-0.141336559823,-0.277311877591,-0.275417310691 -0.369621003307,-0.141336559823,-0.277311877591,0.0795768248736 -0.369621003307,-0.141336559823,-0.277311877591,0.346266169217 -0.369621003307,-0.141336559823,-0.227167215775,-0.142294509854 -0.369621003307,-0.141336559823,-0.227167215775,0.301448159602 -0.369621003307,-0.141336559823,-0.126877892144,0.0352025579281 -0.369621003307,0.018499549715,-0.324322498044,-0.452914378473 -0.369621003307,0.018499549715,-0.324322498044,-0.364165844582 -0.369621003307,0.018499549715,-0.324322498044,-0.319791577637 -0.369621003307,0.018499549715,-0.324322498044,-0.275417310691 -0.369621003307,0.018499549715,-0.324322498044,-0.1866687768 -0.369621003307,0.018499549715,-0.324322498044,-0.142294509854 -0.369621003307,0.018499549715,-0.324322498044,-0.0979202429087 -0.369621003307,0.018499549715,-0.324322498044,-0.0535459759631 -0.369621003307,0.018499549715,-0.324322498044,0.0352025579281 -0.369621003307,0.018499549715,-0.324322498044,0.0795768248736 -0.369621003307,0.018499549715,-0.324322498044,0.123951091819 -0.369621003307,0.018499549715,-0.324322498044,0.21269962571 -0.369621003307,0.018499549715,-0.324322498044,0.257073892656 -0.369621003307,0.018499549715,-0.324322498044,0.301448159602 -0.369621003307,0.018499549715,-0.324322498044,0.345822426547 -0.369621003307,0.018499549715,-0.324322498044,0.346266169217 -0.369621003307,0.018499549715,-0.32118845668,-0.364165844582 -0.369621003307,0.018499549715,-0.32118845668,-0.319791577637 -0.369621003307,0.018499549715,-0.32118845668,-0.275417310691 -0.369621003307,0.018499549715,-0.32118845668,-0.142294509854 -0.369621003307,0.018499549715,-0.32118845668,-0.0979202429087 -0.369621003307,0.018499549715,-0.32118845668,-0.0535459759631 -0.369621003307,0.018499549715,-0.32118845668,0.0352025579281 -0.369621003307,0.018499549715,-0.32118845668,0.0795768248736 -0.369621003307,0.018499549715,-0.32118845668,0.123951091819 -0.369621003307,0.018499549715,-0.32118845668,0.21269962571 -0.369621003307,0.018499549715,-0.32118845668,0.257073892656 -0.369621003307,0.018499549715,-0.32118845668,0.301448159602 -0.369621003307,0.018499549715,-0.32118845668,0.345822426547 -0.369621003307,0.018499549715,-0.32118845668,0.346266169217 -0.369621003307,0.018499549715,-0.314920373953,-0.452914378473 -0.369621003307,0.018499549715,-0.314920373953,-0.364165844582 -0.369621003307,0.018499549715,-0.314920373953,-0.319791577637 -0.369621003307,0.018499549715,-0.314920373953,-0.275417310691 -0.369621003307,0.018499549715,-0.314920373953,-0.1866687768 -0.369621003307,0.018499549715,-0.314920373953,-0.142294509854 -0.369621003307,0.018499549715,-0.314920373953,-0.0979202429087 -0.369621003307,0.018499549715,-0.314920373953,-0.0535459759631 -0.369621003307,0.018499549715,-0.314920373953,0.0352025579281 -0.369621003307,0.018499549715,-0.314920373953,0.123951091819 -0.369621003307,0.018499549715,-0.314920373953,0.21269962571 -0.369621003307,0.018499549715,-0.314920373953,0.257073892656 -0.369621003307,0.018499549715,-0.314920373953,0.301448159602 -0.369621003307,0.018499549715,-0.314920373953,0.345822426547 -0.369621003307,0.018499549715,-0.314920373953,0.346266169217 -0.369621003307,0.018499549715,-0.302384208499,-0.452914378473 -0.369621003307,0.018499549715,-0.302384208499,-0.364165844582 -0.369621003307,0.018499549715,-0.302384208499,-0.319791577637 -0.369621003307,0.018499549715,-0.302384208499,-0.275417310691 -0.369621003307,0.018499549715,-0.302384208499,-0.1866687768 -0.369621003307,0.018499549715,-0.302384208499,-0.142294509854 -0.369621003307,0.018499549715,-0.302384208499,-0.0979202429087 -0.369621003307,0.018499549715,-0.302384208499,0.0352025579281 -0.369621003307,0.018499549715,-0.302384208499,0.123951091819 -0.369621003307,0.018499549715,-0.302384208499,0.21269962571 -0.369621003307,0.018499549715,-0.302384208499,0.257073892656 -0.369621003307,0.018499549715,-0.302384208499,0.301448159602 -0.369621003307,0.018499549715,-0.302384208499,0.345822426547 -0.369621003307,0.018499549715,-0.302384208499,0.346266169217 -0.369621003307,0.018499549715,-0.277311877591,-0.364165844582 -0.369621003307,0.018499549715,-0.277311877591,-0.319791577637 -0.369621003307,0.018499549715,-0.277311877591,-0.275417310691 -0.369621003307,0.018499549715,-0.277311877591,-0.0535459759631 -0.369621003307,0.018499549715,-0.277311877591,0.0352025579281 -0.369621003307,0.018499549715,-0.277311877591,0.21269962571 -0.369621003307,0.018499549715,-0.277311877591,0.257073892656 -0.369621003307,0.018499549715,-0.277311877591,0.345822426547 -0.369621003307,0.018499549715,-0.277311877591,0.346266169217 -0.369621003307,0.018499549715,-0.227167215775,-0.0535459759631 -0.369621003307,0.018499549715,-0.227167215775,0.21269962571 -0.369621003307,0.657843987867,-0.324322498044,-0.364165844582 -0.369621003307,0.657843987867,-0.324322498044,-0.319791577637 -0.369621003307,0.657843987867,-0.324322498044,-0.275417310691 -0.369621003307,0.657843987867,-0.324322498044,-0.1866687768 -0.369621003307,0.657843987867,-0.324322498044,-0.142294509854 -0.369621003307,0.657843987867,-0.324322498044,-0.0979202429087 -0.369621003307,0.657843987867,-0.324322498044,-0.0535459759631 -0.369621003307,0.657843987867,-0.324322498044,0.0352025579281 -0.369621003307,0.657843987867,-0.324322498044,0.0795768248736 -0.369621003307,0.657843987867,-0.324322498044,0.123951091819 -0.369621003307,0.657843987867,-0.324322498044,0.21269962571 -0.369621003307,0.657843987867,-0.324322498044,0.257073892656 -0.369621003307,0.657843987867,-0.324322498044,0.301448159602 -0.369621003307,0.657843987867,-0.324322498044,0.345822426547 -0.369621003307,0.657843987867,-0.32118845668,-0.452914378473 -0.369621003307,0.657843987867,-0.32118845668,-0.364165844582 -0.369621003307,0.657843987867,-0.32118845668,-0.319791577637 -0.369621003307,0.657843987867,-0.32118845668,-0.275417310691 -0.369621003307,0.657843987867,-0.32118845668,-0.1866687768 -0.369621003307,0.657843987867,-0.32118845668,-0.142294509854 -0.369621003307,0.657843987867,-0.32118845668,-0.0979202429087 -0.369621003307,0.657843987867,-0.32118845668,-0.0535459759631 -0.369621003307,0.657843987867,-0.32118845668,0.0352025579281 -0.369621003307,0.657843987867,-0.32118845668,0.0795768248736 -0.369621003307,0.657843987867,-0.32118845668,0.123951091819 -0.369621003307,0.657843987867,-0.32118845668,0.21269962571 -0.369621003307,0.657843987867,-0.32118845668,0.257073892656 -0.369621003307,0.657843987867,-0.32118845668,0.301448159602 -0.369621003307,0.657843987867,-0.32118845668,0.345822426547 -0.369621003307,0.657843987867,-0.32118845668,0.346266169217 -0.369621003307,0.657843987867,-0.314920373953,-0.452914378473 -0.369621003307,0.657843987867,-0.314920373953,-0.364165844582 -0.369621003307,0.657843987867,-0.314920373953,-0.319791577637 -0.369621003307,0.657843987867,-0.314920373953,-0.275417310691 -0.369621003307,0.657843987867,-0.314920373953,-0.1866687768 -0.369621003307,0.657843987867,-0.314920373953,-0.0979202429087 -0.369621003307,0.657843987867,-0.314920373953,-0.0535459759631 -0.369621003307,0.657843987867,-0.314920373953,0.0352025579281 -0.369621003307,0.657843987867,-0.314920373953,0.0795768248736 -0.369621003307,0.657843987867,-0.314920373953,0.123951091819 -0.369621003307,0.657843987867,-0.314920373953,0.21269962571 -0.369621003307,0.657843987867,-0.314920373953,0.257073892656 -0.369621003307,0.657843987867,-0.314920373953,0.301448159602 -0.369621003307,0.657843987867,-0.314920373953,0.345822426547 -0.369621003307,0.657843987867,-0.314920373953,0.346266169217 -0.369621003307,0.657843987867,-0.302384208499,-0.452914378473 -0.369621003307,0.657843987867,-0.302384208499,-0.364165844582 -0.369621003307,0.657843987867,-0.302384208499,-0.319791577637 -0.369621003307,0.657843987867,-0.302384208499,-0.1866687768 -0.369621003307,0.657843987867,-0.302384208499,-0.142294509854 -0.369621003307,0.657843987867,-0.302384208499,-0.0979202429087 -0.369621003307,0.657843987867,-0.302384208499,-0.0535459759631 -0.369621003307,0.657843987867,-0.302384208499,0.0352025579281 -0.369621003307,0.657843987867,-0.302384208499,0.0795768248736 -0.369621003307,0.657843987867,-0.302384208499,0.123951091819 -0.369621003307,0.657843987867,-0.302384208499,0.21269962571 -0.369621003307,0.657843987867,-0.302384208499,0.257073892656 -0.369621003307,0.657843987867,-0.302384208499,0.301448159602 -0.369621003307,0.657843987867,-0.302384208499,0.345822426547 -0.369621003307,0.657843987867,-0.302384208499,0.346266169217 -0.369621003307,0.657843987867,-0.277311877591,-0.452914378473 -0.369621003307,0.657843987867,-0.277311877591,-0.364165844582 -0.369621003307,0.657843987867,-0.277311877591,-0.319791577637 -0.369621003307,0.657843987867,-0.277311877591,-0.275417310691 -0.369621003307,0.657843987867,-0.277311877591,-0.1866687768 -0.369621003307,0.657843987867,-0.277311877591,-0.142294509854 -0.369621003307,0.657843987867,-0.277311877591,-0.0979202429087 -0.369621003307,0.657843987867,-0.277311877591,-0.0535459759631 -0.369621003307,0.657843987867,-0.277311877591,0.0352025579281 -0.369621003307,0.657843987867,-0.277311877591,0.0795768248736 -0.369621003307,0.657843987867,-0.277311877591,0.123951091819 -0.369621003307,0.657843987867,-0.277311877591,0.21269962571 -0.369621003307,0.657843987867,-0.277311877591,0.257073892656 -0.369621003307,0.657843987867,-0.277311877591,0.301448159602 -0.369621003307,0.657843987867,-0.277311877591,0.345822426547 -0.369621003307,0.657843987867,-0.277311877591,0.346266169217 -0.369621003307,0.657843987867,-0.227167215775,-0.452914378473 -0.369621003307,0.657843987867,-0.227167215775,-0.364165844582 -0.369621003307,0.657843987867,-0.227167215775,-0.319791577637 -0.369621003307,0.657843987867,-0.227167215775,-0.275417310691 -0.369621003307,0.657843987867,-0.227167215775,-0.1866687768 -0.369621003307,0.657843987867,-0.227167215775,-0.142294509854 -0.369621003307,0.657843987867,-0.227167215775,-0.0979202429087 -0.369621003307,0.657843987867,-0.227167215775,-0.0535459759631 -0.369621003307,0.657843987867,-0.227167215775,0.123951091819 -0.369621003307,0.657843987867,-0.227167215775,0.301448159602 -0.369621003307,0.657843987867,-0.227167215775,0.346266169217 -0.369621003307,0.657843987867,-0.126877892144,-0.452914378473 -0.369621003307,0.657843987867,-0.126877892144,-0.364165844582 -0.369621003307,0.657843987867,-0.126877892144,-0.319791577637 -0.369621003307,0.657843987867,-0.126877892144,-0.275417310691 -0.369621003307,0.657843987867,-0.126877892144,-0.142294509854 -0.369621003307,0.657843987867,-0.126877892144,-0.0535459759631 -0.369621003307,0.657843987867,-0.126877892144,0.0352025579281 -0.369621003307,0.657843987867,-0.126877892144,0.345822426547 -0.369621003307,0.657843987867,0.0737007551197,-0.452914378473 -0.369621003307,0.657843987867,0.0737007551197,-0.1866687768 -0.369621003307,0.657843987867,0.0737007551197,0.345822426547 diff --git a/extras/c_binding/LICENSE b/extras/c_binding/LICENSE deleted file mode 100644 index 00ce8f0..0000000 --- a/extras/c_binding/LICENSE +++ /dev/null @@ -1,22 +0,0 @@ -MIT License - -Copyright (c) 2020 Tyler H. Chang, Layne T. Watson, Thomas C. H. Lux, -Ali R. Butt, Kirk W. Cameron, and Yili Hong. - -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, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -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. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. diff --git a/extras/c_binding/Makefile b/extras/c_binding/Makefile deleted file mode 100644 index 937fc4d..0000000 --- a/extras/c_binding/Makefile +++ /dev/null @@ -1,25 +0,0 @@ -FORT = gfortran -CC = gcc -CFLAGS = -c -OPTS = -fopenmp -LIBS = dependencies/blas.f dependencies/lapack.f -LEGACY = -std=legacy - -all: test_install.o delsparse_bind_c.o delsparse.o dependencies/slatec.o delsparse.h - $(FORT) $(OPTS) test_install.o delsparse_bind_c.o delsparse.o dependencies/slatec.o $(LIBS) -o test_install - ./test_install - -test_install.o: test_install.c - $(CC) $(CFLAGS) $(OPTS) test_install.c -o test_install.o - -delsparse_bind_c.o: delsparse_bind_c.f90 delsparse.o - $(FORT) $(CFLAGS) $(OPTS) delsparse_bind_c.f90 -o delsparse_bind_c.o - -delsparse.o: delsparse.f90 - $(FORT) $(CFLAGS) $(OPTS) delsparse.f90 -o delsparse.o - -dependencies/slatec.o : dependencies/slatec.f - cd dependencies && $(FORT) $(CFLAGS) $(OPTS) $(LEGACY) slatec.f -o slatec.o - -clean: - rm -f *.o *.mod test_install diff --git a/extras/c_binding/README b/extras/c_binding/README deleted file mode 100644 index 37e65d3..0000000 --- a/extras/c_binding/README +++ /dev/null @@ -1,42 +0,0 @@ -C bindings for the DELAUNAYSPARSE Fortran package. - - -REQUIREMENTS: - - A Fortran compiler that supports BIND(C). - -USAGE: - - Use the C bindings in delsparse_bind_c.f90 to call DELAUNAYSPARSE from - inside a C/C++ program. - - Because C does not support optional arguments, there are 4 variations of - DELAUNAYSPARSE{S|P}: - * c_delaunaysparse{s|p} accepts none of the optional arguments; - * c_delaunaysparse{s|p}_interp accepts an integer ir for specifying the - dimension of the response variables, plus the two variables needed - for computing the value of the interpolant, interp_in and interp_out; - * c_delaunaysparse{s|p}_opts accepts all of the optional arguments - EXCEPT interp_in and interp_out; - * c_delaunaysparse{s|p}_interp_opts accepts all of the optional arguments, - plus the response dimension ir, which cannot be inferred as it is by - the Fortran subroutines. - - When using the 4 subroutines above, keep in mind the following: - * C passes by copy and Fortran passes by reference. Therefore, any non-array - type variable must be manually passed by address (i.e., by using the `&` - character); - * C matrices are stored in row major ordering, while Fortran stores in - column major ordering. Therefore, your data may need to be transposed - before calling any of the above subroutines; - * In C, a double-indexed array is treated as an array of pointers, whereas - Fortran expects a contiguous chunk of memory. Often, it is better to - allocate a one-dimensional array and manually index it, then pass this - "flat" array to the Fortran subroutine. - - Usage examples are provided in the sample file, test_install.c. - -CONTRIBUTORS: - - Tyler Chang, tchang@anl.gov - diff --git a/extras/c_binding/delsparse.f90 b/extras/c_binding/delsparse.f90 deleted file mode 100644 index b093f9a..0000000 --- a/extras/c_binding/delsparse.f90 +++ /dev/null @@ -1,2778 +0,0 @@ -MODULE REAL_PRECISION ! HOMPACK90 module for 64-bit arithmetic. -INTEGER, PARAMETER:: R8=SELECTED_REAL_KIND(13) -END MODULE REAL_PRECISION - -MODULE DELSPARSE_MOD -! This module contains the REAL_PRECISION R8 data type for 64-bit arithmetic -! and interface blocks for the DELAUNAYSPARSES and DELAUNAYSPARSEP -! subroutines for computing the Delaunay simplices containing interpolation -! points Q in R^D given data points PTS. -USE REAL_PRECISION -PUBLIC - -INTERFACE - ! Interface for serial subroutine DELAUNAYSPARSES. - SUBROUTINE DELAUNAYSPARSES( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, & - IBUDGET, CHAIN, EXACT ) - USE REAL_PRECISION, ONLY : R8 - INTEGER, INTENT(IN) :: D, N - REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) - INTEGER, INTENT(IN) :: M - REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) - INTEGER, INTENT(OUT) :: SIMPS(:,:) - REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) - INTEGER, INTENT(OUT) :: IERR(:) - REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) - REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) - INTEGER, INTENT(IN), OPTIONAL :: IBUDGET - LOGICAL, INTENT(IN), OPTIONAL :: CHAIN - LOGICAL, INTENT(IN), OPTIONAL :: EXACT - END SUBROUTINE DELAUNAYSPARSES - - ! Interface for parallel subroutine DELAUNAYSPARSEP. - SUBROUTINE DELAUNAYSPARSEP( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, & - IBUDGET, CHAIN, EXACT, PMODE ) - USE REAL_PRECISION, ONLY : R8 - INTEGER, INTENT(IN) :: D, N - REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) - INTEGER, INTENT(IN) :: M - REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) - INTEGER, INTENT(OUT) :: SIMPS(:,:) - REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) - INTEGER, INTENT(OUT) :: IERR(:) - REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) - REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) - INTEGER, INTENT(IN), OPTIONAL :: IBUDGET - LOGICAL, INTENT(IN), OPTIONAL :: CHAIN - LOGICAL, INTENT(IN), OPTIONAL :: EXACT - INTEGER, INTENT(IN), OPTIONAL :: PMODE - END SUBROUTINE DELAUNAYSPARSEP - - ! Interface for SLATEC subroutine DWNNLS. - SUBROUTINE DWNNLS( W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, & - MODE, IWORK, WORK ) - USE REAL_PRECISION, ONLY : R8 - INTEGER :: IWORK(*), L, MA, MDW, ME, MODE, N - REAL(KIND=R8) :: PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) - END SUBROUTINE DWNNLS - -END INTERFACE - -END MODULE DELSPARSE_MOD - -SUBROUTINE DELAUNAYSPARSES( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EXACT ) -! This is a serial implementation of an algorithm for efficiently performing -! interpolation in R^D via the Delaunay triangulation. The algorithm is fully -! described and analyzed in -! -! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. -! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate -! interpolation in arbitrary dimension via the Delaunay triangulation. In -! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, -! USA. Article 12, 8 pages. -! -! -! On input: -! -! D is the dimension of the space for PTS and Q. -! -! N is the number of data points in PTS. -! -! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the -! coordinates of a single data point in R^D. -! -! M is the number of interpolation points in Q. -! -! Q(1:D,1:M) is a real valued matrix with M columns, each containing the -! coordinates of a single interpolation point in R^D. -! -! -! On output: -! -! PTS and Q have been rescaled and shifted. All the data points in PTS -! are now contained in the unit hyperball in R^D, and the points in Q -! have been shifted and scaled accordingly in relation to PTS. -! -! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns -! in PTS) for the D+1 vertices of the Delaunay simplex containing each -! interpolation point in Q. -! -! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each -! point in Q as a convex combination of the D+1 corresponding vertices -! in SIMPS. -! -! IERR(1:M) contains integer valued error flags associated with the -! computation of each of the M interpolation points in Q. The error -! codes are: -! -! 00 : Succesful interpolation. -! 01 : Succesful extrapolation (up to the allowed extrapolation distance). -! 02 : This point was outside the allowed extrapolation distance; the -! corresponding entries in SIMPS and WEIGHTS contain zero values. -! -! 10 : The dimension D must be positive. -! 11 : Too few data points to construct a triangulation (i.e., N < D+1). -! 12 : No interpolation points given (i.e., M < 1). -! 13 : The first dimension of PTS does not agree with the dimension D. -! 14 : The second dimension of PTS does not agree with the number of points N. -! 15 : The first dimension of Q does not agree with the dimension D. -! 16 : The second dimension of Q does not agree with the number of -! interpolation points M. -! 17 : The first dimension of the output array SIMPS does not match the number -! of vertices needed for a D-simplex (D+1). -! 18 : The second dimension of the output array SIMPS does not match the -! number of interpolation points M. -! 19 : The first dimension of the output array WEIGHTS does not match the -! number of vertices for a a D-simplex (D+1). -! 20 : The second dimension of the output array WEIGHTS does not match the -! number of interpolation points M. -! 21 : The size of the error array IERR does not match the number of -! interpolation points M. -! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. -! 23 : The first dimension of INTERP_IN does not match the first -! dimension of INTERP_OUT. -! 24 : The second dimension of INTERP_IN does not match the number of -! data points PTS. -! 25 : The second dimension of INTERP_OUT does not match the number of -! interpolation points M. -! 26 : The budget supplied in IBUDGET does not contain a positive -! integer. -! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. -! 28 : The size of the RNORM output array does not match the number of -! interpolation points M. -! -! 30 : Two or more points in the data set PTS are too close together with -! respect to the working precision (EPS), which would result in a -! numerically degenerate simplex. -! 31 : All the data points in PTS lie in some lower dimensional linear -! manifold (up to the working precision), and no valid triangulation -! exists. -! 40 : An error caused DELAUNAYSPARSES to terminate before this value could -! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may -! contain garbage values. -! -! 50 : A memory allocation error occurred while allocating the work array -! WORK. -! -! 60 : The budget was exceeded before the algorithm converged on this -! value. If the dimension is high, try increasing IBUDGET. This -! error can also be caused by a working precision EPS that is too -! small for the conditioning of the problem. -! -! 61 : A value that was judged appropriate later caused LAPACK to encounter a -! singularity. Try increasing the value of EPS. -! -! 70 : Allocation error for the extrapolation work arrays. -! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection -! of an extrapolation point onto the convex hull. -! 72 : The SLATEC subroutine DWNNLS has reported a usage error. -! -! The errors 72, 80--83 should never occur, and likely indicate a -! compiler bug or hardware failure. -! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. -! 81 : The LAPACK subroutine DGETRF has reported an illegal value. -! 82 : The LAPACK subroutine DGETRS has reported an illegal value. -! 83 : The LAPACK subroutine DORMQR has reported an illegal value. -! -! -! Optional arguments: -! -! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of -! the data points in PTS on input. The first dimension of INTERP_IN is -! inferred to be the dimension of these response vectors, and the -! second dimension must match N. If present, the response values will -! be computed for each interpolation point in Q, and stored in INTERP_OUT, -! which therefore must also be present. If both INTERP_IN and INTERP_OUT -! are omitted, only the containing simplices and convex combination -! weights are returned. -! -! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each -! interpolation point in Q on output. The first dimension of INTERP_OUT -! must match the first dimension of INTERP_IN, and the second dimension -! must match M. If present, the response values at each interpolation -! point are computed as a convex combination of the response values -! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing -! that interpolation point. Therefore, if INTERP_OUT is present, then -! INTERP_IN must also be present. If both are omitted, only the -! simplices and convex combination weights are returned. -! -! EPS contains the real working precision for the problem on input. By default, -! EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff for the -! machine. In general, any values that differ by less than EPS are judged -! as equal, and any weights that are greater than -EPS are judged as -! nonnegative. EPS cannot take a value less than the default value of -! \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, the default -! value will be used instead automatically. -! -! EXTRAP contains the real maximum extrapolation distance (relative to the -! diameter of PTS) on input. Interpolation at a point outside the convex -! hull of PTS is done by projecting that point onto the convex hull, and -! then doing normal Delaunay interpolation at that projection. -! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) -! units outside the convex hull of PTS will not be done and an error code -! of 2 will be returned. Note that computing the projection can be -! expensive. Setting EXTRAP=0 will cause all extrapolation points to be -! ignored without ever computing a projection. By default, EXTRAP=0.1 -! (extrapolate by up to 10% of the diameter of PTS). -! -! RNORM(1:M) contains the real unscaled projection (2-norm) distances from -! any projection computations on output. If not present, these distances -! are still computed for each extrapolation point, but are never returned. -! -! IBUDGET on input contains the integer budget for performing flips while -! iterating toward the simplex containing each interpolation point in -! Q. This prevents DELAUNAYSPARSES from falling into an infinite loop when -! an inappropriate value of EPS is given with respect to the problem -! conditioning. By default, IBUDGET=50000. However, for extremely -! high-dimensional problems and pathological inputs, the default value -! may be insufficient. -! -! CHAIN is a logical input argument that determines whether a new first -! simplex should be constructed for each interpolation point -! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." -! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not -! recommended, unless the size of the triangulation is relatively small -! or the interpolation points are known to be tightly clustered. -! -! EXACT is a logical input argument that determines whether the exact -! diameter should be computed and whether a check for duplicate data -! points should be performed in advance. When EXACT=.FALSE., the -! diameter of PTS is approximated by twice the distance from the -! barycenter of PTS to the farthest point in PTS, and no check is -! done to find the closest pair of points, which could result in hard -! to find bugs later on. When EXACT=.TRUE., the exact diameter is -! computed and an error is returned whenever PTS contains duplicate -! values up to the precision EPS. By default EXACT=.TRUE., but setting -! EXACT=.FALSE. could result in significant speedup when N is large. -! It is strongly recommended that most users leave EXACT=.TRUE., as -! setting EXACT=.FALSE. could result in input errors that are difficult -! to identify. Also, the diameter approximation could be wrong by up to -! a factor of two. -! -! -! Subroutines and functions directly referenced from BLAS are -! DDOT, DGEMV, DNRM2, DTRSM, -! and from LAPACK are -! DGEQP3, DGETRF, DGETRS, DORMQR. -! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its -! SLATEC dependencies have been slightly edited to comply with the Fortran -! 2008 standard, with all print statements and references to stderr being -! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 -! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS -! Algorithm 777) is used for the real data type. The REAL_PRECISION module, -! DELAUNAYSPARSES, and DWNNLS and its dependencies comply with the Fortran -! 2008 standard. -! -! Primary Author: Tyler H. Chang -! Last Update: March, 2020 -! -USE REAL_PRECISION, ONLY : R8 -IMPLICIT NONE - -! Input arguments. -INTEGER, INTENT(IN) :: D, N -REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) ! Rescaled on output. -INTEGER, INTENT(IN) :: M -REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) ! Rescaled on output. -! Output arguments. -INTEGER, INTENT(OUT) :: SIMPS(:,:) -REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) -INTEGER, INTENT(OUT) :: IERR(:) -! Optional arguments. -REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) -REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) -REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP -REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) -INTEGER, INTENT(IN), OPTIONAL :: IBUDGET -LOGICAL, INTENT(IN), OPTIONAL :: CHAIN -LOGICAL, INTENT(IN), OPTIONAL :: EXACT - -! Local copies of optional input arguments. -REAL(KIND=R8) :: EPSL, EXTRAPL -INTEGER :: IBUDGETL -LOGICAL :: CHAINL, EXACTL - -! Local variables. -INTEGER :: I, J, K ! Loop iteration variables. -INTEGER :: IEXTRAPS ! Extrapolation budget. -INTEGER :: ITMP, JTMP ! Temporary variables for swapping, looping, etc. -INTEGER :: LWORK ! Size of the work array. -INTEGER :: MI ! Index of current interpolation point. -REAL(KIND=R8) :: CURRRAD ! Radius of the current circumsphere. -REAL(KIND=R8) :: MINRAD ! Minimum circumsphere radius observed. -REAL(KIND=R8) :: PTS_DIAM ! Scaled diameter of data set. -REAL(KIND=R8) :: PTS_SCALE ! Data scaling factor. -REAL(KIND=R8) :: RNORML ! Euclidean norm of the projection residual. -REAL(KIND=R8) :: SIDE1, SIDE2 ! Signs (+/-1) denoting sides of a facet. - -! Local arrays, requiring O(d^2) additional memory. -INTEGER :: IPIV(D) ! Pivot indices. -INTEGER :: SEED(D+1) ! Copy of the SEED simplex. Only used if CHAIN = .TRUE. -REAL(KIND=R8) :: AT(D,D) ! The transpose of A, the linear coefficient matrix. -REAL(KIND=R8) :: B(D) ! The RHS of a linear system. -REAL(KIND=R8) :: CENTER(D) ! The circumcenter of a simplex. -REAL(KIND=R8) :: LQ(D,D) ! Holds LU or QR factorization of AT. -REAL(KIND=R8) :: PLANE(D+1) ! The hyperplane containing a facet. -REAL(KIND=R8) :: PRGOPT_DWNNLS(1) ! Options array for DWNNLS. -REAL(KIND=R8) :: PROJ(D) ! The projection of the current iterate. -REAL(KIND=R8) :: TAU(D) ! Householder reflector constants. -REAL(KIND=R8) :: X(D) ! The solution to a linear system. - -! Extrapolation work arrays are only allocated if DWNNLS is called. -INTEGER, ALLOCATABLE :: IWORK_DWNNLS(:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: W_DWNNLS(:,:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: WORK(:) ! Allocated with size LWORK. -REAL(KIND=R8), ALLOCATABLE :: WORK_DWNNLS(:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: X_DWNNLS(:) ! Only for DWNNLS. - -! External functions and subroutines. -REAL(KIND=R8), EXTERNAL :: DDOT ! Inner product (BLAS). -REAL(KIND=R8), EXTERNAL :: DNRM2 ! Euclidean norm (BLAS). -EXTERNAL :: DGEMV ! General matrix vector multiply (BLAS) -EXTERNAL :: DGEQP3 ! Perform a QR factorization with column pivoting (LAPACK). -EXTERNAL :: DGETRF ! Perform a LU factorization with partial pivoting (LAPACK). -EXTERNAL :: DGETRS ! Use the output of DGETRF to solve a linear system (LAPACK). -EXTERNAL :: DORMQR ! Apply householder reflectors to a matrix (LAPACK). -EXTERNAL :: DTRSM ! Perform a triangular solve (BLAS). -EXTERNAL :: DWNNLS ! Solve an inequality constrained least squares problem - ! (SLATEC). - -! Check for input size and dimension errors. -IF (D < 1) THEN ! The dimension must satisfy D > 0. - IERR(:) = 10; RETURN; END IF -IF (N < D+1) THEN ! Must have at least D+1 data points. - IERR(:) = 11; RETURN; END IF -IF (M < 1) THEN ! Must have at least one interpolation point. - IERR(:) = 12; RETURN; END IF -IF (SIZE(PTS,1) .NE. D) THEN ! Dimension of PTS array should match. - IERR(:) = 13; RETURN; END IF -IF (SIZE(PTS,2) .NE. N) THEN ! Number of data points should match. - IERR(:) = 14; RETURN; END IF -IF (SIZE(Q,1) .NE. D) THEN ! Dimension of Q should match. - IERR(:) = 15; RETURN; END IF -IF (SIZE(Q,2) .NE. M) THEN ! Number of interpolation points should match. - IERR(:) = 16; RETURN; END IF -IF (SIZE(SIMPS,1) .NE. D+1) THEN ! Need space for D+1 vertices per simplex. - IERR(:) = 17; RETURN; END IF -IF (SIZE(SIMPS,2) .NE. M) THEN ! There will be M output simplices. - IERR(:) = 18; RETURN; END IF -IF (SIZE(WEIGHTS,1) .NE. D+1) THEN ! There will be D+1 weights per simplex. - IERR(:) = 19; RETURN; END IF -IF (SIZE(WEIGHTS,2) .NE. M) THEN ! One vector of weights per simplex. - IERR(:) = 20; RETURN; END IF -IF (SIZE(IERR) .NE. M) THEN ! An error flag for each interpolation point. - IERR(:) = 21; RETURN; END IF - -! Check for optional arguments. -IF (PRESENT(INTERP_IN) .NEQV. PRESENT(INTERP_OUT)) THEN - IERR(:) = 22; RETURN; END IF -IF (PRESENT(INTERP_IN)) THEN ! Sizes must agree. - IF (SIZE(INTERP_IN,1) .NE. SIZE(INTERP_OUT,1)) THEN - IERR(:) = 23 ; RETURN; END IF - IF(SIZE(INTERP_IN,2) .NE. N) THEN - IERR(:) = 24; RETURN; END IF - IF (SIZE(INTERP_OUT,2) .NE. M) THEN - IERR(:) = 25; RETURN; END IF - INTERP_OUT(:,:) = 0.0_R8 ! Initialize output to zeros. -END IF -EPSL = SQRT(EPSILON(0.0_R8)) ! Get the machine unit roundoff constant. -IF (PRESENT(EPS)) THEN - IF (EPSL < EPS) THEN ! If the given precision is too small, ignore it. - EPSL = EPS - END IF -END IF -IF (PRESENT(IBUDGET)) THEN - IBUDGETL = IBUDGET ! Use the given budget if present. - IF (IBUDGETL < 1) THEN - IERR(:) = 26; RETURN; END IF -ELSE - IBUDGETL = 50000 ! Default value for budget. -END IF -IF (PRESENT(EXTRAP)) THEN - EXTRAPL = EXTRAP - IF (EXTRAPL < 0) THEN ! Check that the extrapolation distance is legal. - IERR(:) = 27; RETURN; END IF -ELSE - EXTRAPL = 0.1_R8 ! Default extrapolation distance (for normalized points). -END IF -IF (PRESENT(RNORM)) THEN - IF (SIZE(RNORM,1) .NE. M) THEN ! The length of the array must match. - IERR(:) = 28; RETURN; END IF - RNORM(:) = 0.0_R8 ! Initialize output to zeros. -END IF -IF (PRESENT(CHAIN)) THEN - CHAINL = CHAIN ! Turn chaining on, if necessarry. - SEED(:) = 0 ! Initialize SEED in case it is needed. -ELSE - CHAINL = .FALSE. -END IF -IF (PRESENT(EXACT)) THEN - EXACTL = EXACT ! Set error checking and exact diameter computations. -ELSE - EXACTL = .TRUE. -END IF - -! Scale and center the data points and interpolation points. -CALL RESCALE(MINRAD, PTS_DIAM, PTS_SCALE) -IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. - IERR(:) = 30; RETURN; END IF - -! Query DGEQP3 for optimal work array size (LWORK). -LWORK = -1 -CALL DGEQP3(D,D,LQ,D,IPIV,TAU,B,LWORK,IERR(1)) -LWORK = INT(B(1)) ! Compute the optimal work array size. -ALLOCATE(WORK(LWORK), STAT=I) ! Allocate WORK to size LWORK. -IF (I .NE. 0) THEN ! Check for memory allocation errors. - IERR(:) = 50; RETURN; END IF - -! Initialize all error codes to "TBD" values. -IERR(:) = 40 - -! Outer loop over all interpolation points (in Q). -OUTER : DO MI = 1, M - - ! Check if this interpolation point was already found. - IF (IERR(MI) .EQ. 0) CYCLE OUTER - - ! Initialize the projection and reset the residual. - PROJ(:) = Q(:,MI) - RNORML = 0.0_R8 - - ! Check if extrapolation is enabled. - IF (EXTRAPL < EPSL) THEN - IEXTRAPS = -1 ! If not, set the extrapolation budget negative. - ELSE - IEXTRAPS = 1 ! Allow for exactly one projection for this point. - END IF - - ! If there is no useable seed or if chaining is turned off, then make a new - ! simplex. - IF( (.NOT. CHAINL) .OR. SEED(1) .EQ. 0) THEN - CALL MAKEFIRSTSIMP() - IF(IERR(MI) .NE. 0) CYCLE OUTER - ! Otherwise, use the seed. - ELSE - ! Copy the seed to the current simplex. - SIMPS(:,MI) = SEED(:) - ! Rebuild the linear system. - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - - ! Inner loop searching for a simplex containing the point Q(:,MI). - INNER : DO K = 1, IBUDGETL - - ! If chaining is on, save each good simplex as the next seed. - IF (CHAINL) SEED(:) = SIMPS(:,MI) - - ! Check if the current simplex contains Q(:,MI). - IF (PTINSIMP()) EXIT INNER - IF (IERR(MI) .NE. 0) CYCLE OUTER ! Check for an error flag. - - ! Swap out the least weighted vertex, but save its value in case it - ! needs to be restored later. - JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) - ITMP = SIMPS(JTMP,MI) - SIMPS(JTMP,MI) = SIMPS(D+1,MI) - - ! If the least weighted vertex (index JTMP) is not the first vertex, - ! then just drop row (JTMP-1) from the linear system (corresponding - ! to column (JTMP-1) of A^T). - IF(JTMP .NE. 1) THEN - AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) - ! However, if JTMP = 1, then both A^T and B must be reconstructed. - ELSE - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - - ! Compute the next simplex (do one flip). - CALL MAKESIMPLEX() - IF (IERR(MI) .NE. 0) CYCLE OUTER - - ! If no vertex was found, then this is an extrapolation point. - IF (SIMPS(D+1,MI) .EQ. 0) THEN - - ! If extrapolation is not allowed (EXTRAP=0), do not proceed. - IF (IEXTRAPS < 0) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! Set the error flag and skip this point. - IERR(MI) = 2; CYCLE OUTER - - ! If extrapolation is allowed (EXTRAP>0), check the budget. - ELSE IF (IEXTRAPS .EQ. 0) THEN - ! A second projection has been attempted. This code is rarely - ! called, except in extreme cases involving nearly singular - ! simplices near the convex hull of P. - - ! Swap the weights to match the simplex indices, and zero the - ! most negative weight. - WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) - WEIGHTS(D+1,MI) = 0.0_R8 - ! Loop through all the remaining facets from which Q(:,MI) is - ! visible, and attempt to flip across each one. - DO WHILE (SIMPS(D+1,MI) .EQ. 0) - ! Restore the previous simplex and linear system. - SIMPS(D+1,MI) = ITMP - AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - ! Find the next most negative weight. - JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) - ! Check if WEIGHTS(JTMP,MI) .GE. 0. - IF (WEIGHTS(JTMP,MI) .GE. -EPSL) THEN - ! There is no other direction to flip, so Q(:,MI) must be - ! within EPSL of the current simplex. - ! Project Q(:,MI) onto the current simplex. - - ! Since at least one projection has already been done, - ! the work arrays have already been allocated. - PRGOPT_DWNNLS(1) = 1.0_R8 - IWORK_DWNNLS(1) = 6*D + 6 - IWORK_DWNNLS(2) = 2*D + 2 - ! Set equality constraint. - W_DWNNLS(1,1:D+2) = 1.0_R8 - ! Populate LS coefficient matrix and RHS. - FORALL (I=1:D+1) W_DWNNLS(2:D+1,I) = PTS(:,SIMPS(I,MI)) - W_DWNNLS(2:D+1,D+2) = PROJ(:) - ! Project onto the current simplex. - CALL DWNNLS(W_DWNNLS, D+1, 1, D, D+1, 0, PRGOPT_DWNNLS, & - WEIGHTS(:,MI), WORK(1), IERR(MI), IWORK_DWNNLS, & - WORK_DWNNLS) - IF (IERR(MI) .EQ. 1) THEN ! Failure to converge. - IERR(MI) = 71; CYCLE OUTER - ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. - IERR(MI) = 72; CYCLE OUTER - END IF - ! A solution has been found; return it. - EXIT INNER - END IF - ! Otherwise, swap the vertices. - ITMP = SIMPS(JTMP,MI) - SIMPS(JTMP,MI) = SIMPS(D+1,MI) - ! Swap the weights to match, and zero the most negative weight. - WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) - WEIGHTS(D+1,MI) = 0.0_R8 - ! If the least weighted vertex (index JTMP) is not the first - ! vertex, then just drop row (JTMP-1) from the linear system - ! (corresponding to column (JTMP-1) of A^T). - IF (JTMP .NE. 1) THEN - AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) - ! However, if JTMP=1, then both A^T and B must be reconstructed. - ELSE - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - ! Compute another simplex (try to flip again). - CALL MAKESIMPLEX(); IF (IERR(MI) .NE. 0) CYCLE OUTER - END DO - ! If the loop terminates, then a good direction was found. - ! Resume the visibility walk as normal. - CYCLE INNER - END IF - - ! Otherwise, project the extrapolation point onto the convex hull. - CALL PROJECT() - IF (IERR(MI) .NE. 0) CYCLE OUTER - - ! Check the value of RNORML for over-extrapolation. - IF (RNORML > EXTRAPL * PTS_DIAM) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! If present, record the unscaled RNORM output. - IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE - ! Set the error flag and skip this point. - IERR(MI) = 2; CYCLE OUTER - END IF - - ! Otherwise, restore the previous simplex and continue with the - ! projected value. - SIMPS(D+1,MI) = ITMP - AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - IEXTRAPS = IEXTRAPS - 1 ! Decrement the budget. - END IF - - ! End of inner loop for finding each interpolation point. - END DO INNER - - ! Check for budget violation conditions. - IF (K > IBUDGETL) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! Set the error flag and skip this point. - IERR(MI) = 60; CYCLE OUTER - END IF - - ! If the residual is nonzero, set the extrapolation flag. - IF (RNORML > EPSL) IERR(MI) = 1 - - ! If present, record the RNORM output. - IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE - -END DO OUTER ! End of outer loop over all interpolation points. - -! If INTERP_IN and INTERP_OUT are present, compute all values f(q). -IF (PRESENT(INTERP_IN)) THEN - ! Loop over all interpolation points. - DO MI = 1, M - ! Check for errors. - IF (IERR(MI) .LE. 1) THEN - ! Compute the weighted sum of vertex response values. - DO K = 1, D+1 - INTERP_OUT(:,MI) = INTERP_OUT(:,MI) & - + INTERP_IN(:,SIMPS(K,MI)) * WEIGHTS(K,MI) - END DO - END IF - END DO -END IF - -! Free dynamic work arrays. -DEALLOCATE(WORK) -IF (ALLOCATED(IWORK_DWNNLS)) DEALLOCATE(IWORK_DWNNLS) -IF (ALLOCATED(WORK_DWNNLS)) DEALLOCATE(WORK_DWNNLS) -IF (ALLOCATED(W_DWNNLS)) DEALLOCATE(W_DWNNLS) -IF (ALLOCATED(X_DWNNLS)) DEALLOCATE(X_DWNNLS) - -RETURN - -CONTAINS ! Internal subroutines and functions. - -SUBROUTINE MAKEFIRSTSIMP() -! Iteratively construct the first simplex by choosing points that -! minimize the radius of the smallest circumball. Let P_1, P_2, ..., P_K -! denote the current set of vertices for the simplex. Let P* denote the -! candidate vertex to be added to the simplex. Let CENTER denote the -! circumcenter of the simplex. Then -! -! X = CENTER - P_1 -! -! is given by the minimum norm solution to the underdetermined linear system -! -! A X = B, where -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_K - P_1, P* - P_1 ] and -! B = [ /2, /2, ..., /2 ]^T. -! -! Then the radius of the smallest circumsphere is CURRRAD = \| X \|, -! and the next vertex is given by P_{K+1} = argmin_{P*} CURRRAD, where P* -! ranges over points in PTS that are not already a vertex of the simplex. -! -! On output, this subroutine fully populates the matrix A^T and vector B, -! and fills SIMPS(:,MI) with the indices of a valid Delaunay simplex. - -! Find the first point, i.e., the closest point to Q(:,MI). -SIMPS(:,MI) = 0 -MINRAD = HUGE(0.0_R8) -DO I = 1, N - ! Check the distance to Q(:,MI). - CURRRAD = DNRM2(D, PTS(:,I) - PROJ(:), 1) - IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(1,MI) = I; END IF -END DO -! Find the second point, i.e., the closest point to PTS(:,SIMPS(1,MI)). -MINRAD = HUGE(0.0_R8) -DO I = 1, N - ! Skip repeated vertices. - IF (I .EQ. SIMPS(1,MI)) CYCLE - ! Check the diameter of the resulting circumsphere. - CURRRAD = DNRM2(D, PTS(:,I)-PTS(:,SIMPS(1,MI)), 1) - IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(2,MI) = I; END IF -END DO -IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. - IERR(MI) = 30; RETURN; END IF -! Set up the first row of the linear system. -AT(:,1) = PTS(:,SIMPS(2,MI)) - PTS(:,SIMPS(1,MI)) -B(1) = DDOT(D, AT(:,1), 1, AT(:,1), 1) / 2.0_R8 -! Loop to collect the remaining D-1 vertices for the first simplex. -DO I = 2, D - ! For numerical stability, refactor A^T P = Q R for the next iteration. - LQ(:,1:I-1) = AT(:,1:I-1) - CALL DGEQP3(D, I-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 80; RETURN - END IF - ! Set the RHS to P^T B. - FORALL (ITMP = 1:I-1) X(ITMP) = B(IPIV(ITMP)) - ! Solve R^T Q^T X = P^T B for Q^T X, and save for later. - CALL DTRSM('L', 'U', 'T', 'N', I-1, 1, 1.0_R8, LQ, D, X, D) - ! Make a copy for computing the current center. - CENTER(1:I-1) = X(1:I-1) - CENTER(I:D) = 0.0_R8 - ! Apply Q from the left. - CALL DORMQR('L', 'N', D, 1, I-1, LQ, D, TAU, CENTER, D, WORK, & - LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 83; RETURN - END IF - CENTER = CENTER + PTS(:,SIMPS(1,MI)) - ! Re-initialize the radius for each iteration. - MINRAD = HUGE(0.0_R8) - ! Check each point P* in PTS. - DO J = 1, N - ! Check that this point is not already in the simplex. - IF (ANY(SIMPS(:,MI) .EQ. J)) CYCLE - ! If PTS(:,J) is more than twice MINRAD from CENTER, do a quick skip. - IF (DNRM2(D, CENTER - PTS(:,J), 1) > 2.0_R8 * MINRAD) CYCLE - ! Perform a rank-1 update to the current QR factorization of A^T by - ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI)) by Q^T and storing in the - ! final column of R. - LQ(:,I) = PTS(:,J) - PTS(:,SIMPS(1,MI)) - CALL DORMQR('L', 'T', D, 1, I-1, LQ(:,1:I-1), D, TAU, LQ(:,I), D, & - WORK, LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 83; RETURN - END IF - ! Implicitly apply the next Householder reflector. - LQ(I,I) = DNRM2(D+1-I, LQ(I:D,I), 1) - IF (LQ(I,I) < EPSL) THEN ! A is rank-deficient. - CYCLE ! If rank-deficient, skip this point. - END IF - ! Update the current radius by \| Q^T X \| = \| X \|. - WORK(1:I-1) = (LQ(1:I-1,I) / 2.0_R8) - X(1:I-1) - WORK(I) = LQ(I,I) / 2.0_R8 - X(I) = DDOT(I, LQ(1:I,I), 1, WORK(1:I), 1) / LQ(I,I) - CURRRAD = DNRM2(I, X(1:I), 1) - ! Compare the last component of Q^T X to the current minimum. - IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(I+1,MI) = J; END IF - END DO - ! Check that a point was found. If not, then all the points must lie in a - ! lower dimensional linear manifold (error case). - IF (SIMPS(I+1,MI) .EQ. 0) THEN; IERR(MI) = 31; RETURN; END IF - ! If all operations were successful, add the best P* to the linear system. - AT(:,I) = PTS(:,SIMPS(I+1,MI)) - PTS(:,SIMPS(1,MI)) - B(I) = DDOT(D, AT(:,I), 1, AT(:,I), 1) / 2.0_R8 -END DO -IERR(MI) = 0 ! Set error flag to 'success' for a normal return. -RETURN -END SUBROUTINE MAKEFIRSTSIMP - -SUBROUTINE MAKESIMPLEX() -! Given a Delaunay facet F whose containing hyperplane does not contain -! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' -! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F -! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the -! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly -! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing -! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices -! P_1, P_2, ..., P_D, P*. Then -! -! X = CENTER - P_1 -! -! is given by the solution to the nonsingular linear system -! -! A X = B where -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and -! B = [ /2, /2, ..., /2 ]^T. -! -! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the -! candidate P* that satisfies both of the following: -! -! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) -! must be on the same side of PLANE. -! -! 2) The circumball about CENTER must not contain any points in PTS in its -! interior (Delaunay property). -! -! The above are necessary and sufficient conditions for flipping the -! Delaunay simplex, given that F is indeed a Delaunay facet. -! -! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices -! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex -! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and -! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were -! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an -! extrapolation point (not a convex combination of points in PTS). - -! Compute the hyperplane PLANE. -CALL MAKEPLANE() -IF(IERR(MI) .NE. 0) RETURN ! Check for errors. -! Compute the sign for the side of PLANE containing Q(:,MI). -SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) -SIDE1 = SIGN(1.0_R8,SIDE1) -! Initialize the center, radius, and simplex. -SIMPS(D+1,MI) = 0 -CENTER(:) = 0.0_R8 -MINRAD = HUGE(0.0_R8) -! If D=1, just check for the closest point on SIDE1 of PTS(:,SIMPS(1,MI)). -IF (D .EQ. 1) THEN - ! Loop through all points P* in PTS. - DO I = 1, N - ! Check that P* is on the appropriate halfspace. - SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 - IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE - ! Check that P* is closer than the current solution. - IF (SIDE2 > MINRAD) CYCLE - ! Update the minimum distance and save the index I. - MINRAD = SIDE2 - SIMPS(2,MI) = I - END DO - IERR(MI) = 0 ! Reset the error flag to 'success' code. - ! Check for extrapolation condition. - IF(SIMPS(2,MI) .EQ. 0) RETURN - ! Add new point to the linear system. - AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) - B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 - RETURN -END IF -! Set the RHS to P^T B. -FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) -! Solve R^T Q^T X = P^T B for Q^T X. -CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) -! Loop through all points P* in PTS. -DO I = 1, N - ! Check that P* is inside the current ball. - IF (DNRM2(D, PTS(:,I) - CENTER(:), 1) > MINRAD) CYCLE ! If not, skip. - ! Check that P* is on the appropriate halfspace. - SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) - IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE ! If not, skip. - ! Perform a rank-1 update to the current QR factorization of A^T by - ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the - ! final column of R. - LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) - CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & - LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 83; RETURN - END IF - ! Update the last element of Q^T X. - WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) - WORK(D) = LQ(D,D) / 2.0_R8 - CENTER(1:D-1) = X(1:D-1) - CENTER(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) - ! Get the center by applying Q to the solution. - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER, D, WORK, LWORK, & - IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 83; RETURN - END IF - ! Update the new radius, center, and simplex. - MINRAD = DNRM2(D, CENTER, 1) - CENTER(:) = CENTER(:) + PTS(:,SIMPS(1,MI)) - SIMPS(D+1,MI) = I -END DO -IERR(MI) = 0 ! Reset the error flag to 'success' code. -! Check for extrapolation condition. -IF(SIMPS(D+1,MI) .EQ. 0) RETURN -! Add new point to the linear system. -AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) -B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 -RETURN -END SUBROUTINE MAKESIMPLEX - -SUBROUTINE MAKEPLANE() -! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed -! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. -! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal -! vector is any nonzero vector in ker A, where the matrix -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. -! -! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR -! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. -! Then the last column of Q is orthogonal to the range of A^T, and in ker A. -! -! Upon output, PLANE(1:D) contains the normal vector c and PLANE(D+1) -! contains \alpha defining the plane. Also, LQ, IPIV, and TAU define a QR -! factorizaton of the first D-1 columns of A^T. - -IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. - ! Compute the QR factorization. - IPIV=0 - LQ = AT - CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 80; RETURN - END IF - ! The nullspace is given by the last column of Q. - PLANE(1:D-1) = 0.0_R8 - PLANE(D) = 1.0_R8 - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & - LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 83; RETURN - END IF - ! Calculate the constant \alpha defining the plane. - PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) -ELSE ! Special case where D=1. - PLANE(1) = 1.0_R8 - PLANE(2) = PTS(1,SIMPS(1,MI)) -END IF -RETURN -END SUBROUTINE MAKEPLANE - -FUNCTION PTINSIMP() RESULT(TF) -! Determine if any interpolation points are in the current simplex, whose -! vertices P_1, P_2, ..., P_{D+1} are indexed by SIMPS(:,MI). These -! vertices determine a positive cone with generators V_I = P_{I+1} - P_1, -! I = 1, ..., D. For each interpolation point Q* in Q, Q* - P_1 can be -! expressed as a unique linear combination of the V_I. If all these linear -! weights are nonnegative and sum to less than or equal to 1.0, then Q* is -! in the simplex with vertices {P_I}_{I=1}^{D+1}. -! -! If any interpolation points in Q are contained in the simplex whose -! vertices are indexed by SIMPS(:,MI), then those points are marked as solved -! and the values of SIMPS and WEIGHTS are updated appropriately. On output, -! WEIGHTS(:,MI) contains the affine weights for producing Q(:,MI) as an -! affine combination of the points in PTS indexed by SIMPS(:,MI). If these -! weights are nonnegative, then PTINSIMP() returns TRUE. - -! Initialize the return value and local variables. -LOGICAL :: TF ! True/False value. -TF = .FALSE. - -! Compute the LU factorization of the matrix A^T, whose columns are -! P_{I+1} - P_1. -LQ = AT -CALL DGETRF(D, D, LQ, D, IPIV, IERR(MI)) -IF (IERR(MI) < 0) THEN ! LAPACK illegal input. - IERR(MI) = 81; RETURN -ELSE IF (IERR(MI) > 0) THEN ! Rank-deficiency detected. - IERR(MI) = 61; RETURN -END IF -! Solve A^T w = WORK to get the affine weights for Q(:,MI) or its projection. -WORK(1:D) = PROJ(:) - PTS(:,SIMPS(1,MI)) -CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(1:D), D, IERR(MI)) -IF (IERR(MI) < 0) THEN ! LAPACK illegal input. - IERR(MI) = 82; RETURN -END IF -WEIGHTS(2:D+1,MI) = WORK(1:D) -WEIGHTS(1,MI) = 1.0_R8 - SUM(WEIGHTS(2:D+1,MI)) -! Check if the weights for Q(:,MI) are nonnegative. -IF (ALL(WEIGHTS(:,MI) .GE. -EPSL)) TF = .TRUE. - -! Compute the affine weights for the rest of the interpolation points. -DO I = MI+1, M - ! Check that no solution has already been found. - IF (IERR(I) .NE. 40) CYCLE - ! Solve A^T w = WORK to get the affine weights for Q(:,I). - WORK(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) - CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(2:D+1), D, ITMP) - IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. - ! Check if the weights define a convex combination. - WORK(1) = 1.0_R8 - SUM(WORK(2:D+1)) - IF (ALL(WORK(1:D+1) .GE. -EPSL)) THEN - ! Copy the simplex indices and weights then flag as complete. - SIMPS(:,I) = SIMPS(:,MI) - WEIGHTS(:,I) = WORK(1:D+1) - IERR(I) = 0 - END IF -END DO -RETURN -END FUNCTION PTINSIMP - -SUBROUTINE PROJECT() -! Project a point outside the convex hull of the point set onto the convex hull -! by solving an inequality constrained least squares problem. The solution to -! the least squares problem gives the projection as a convex combination of the -! data points. The projection can then be computed by performing a matrix -! vector multiplication. - -! Allocate work arrays. -IF (.NOT. ALLOCATED(IWORK_DWNNLS)) THEN - ALLOCATE(IWORK_DWNNLS(D+1+N), STAT=IERR(MI)) - IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF -END IF -IF (.NOT. ALLOCATED(WORK_DWNNLS)) THEN - ALLOCATE(WORK_DWNNLS(D+1+N*5), STAT=IERR(MI)) - IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF -END IF -IF (.NOT. ALLOCATED(W_DWNNLS)) THEN - ALLOCATE(W_DWNNLS(D+1,N+1), STAT=IERR(MI)) - IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF -END IF -IF (.NOT. ALLOCATED(X_DWNNLS)) THEN - ALLOCATE(X_DWNNLS(N), STAT=IERR(MI)) - IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF -END IF - -! Initialize work array and settings values. -PRGOPT_DWNNLS(1) = 1.0_R8 -IWORK_DWNNLS(1) = D+1+5*N -IWORK_DWNNLS(2) = D+1+N -W_DWNNLS(1, :) = 1.0_R8 ! Set convexity (equality) constraint. -W_DWNNLS(2:D+1,1:N) = PTS(:,:) ! Copy data points. -W_DWNNLS(2:D+1,N+1) = PROJ(:) ! Copy extrapolation point. -! Compute the solution to the inequality constrained least squares problem to -! get the projection coefficients. -CALL DWNNLS(W_DWNNLS, D+1, 1, D, N, 0, PRGOPT_DWNNLS, X_DWNNLS, RNORML, & - IERR(MI), IWORK_DWNNLS, WORK_DWNNLS) -IF (IERR(MI) .EQ. 1) THEN ! Failure to converge. - IERR(MI) = 71; RETURN -ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. - IERR(MI) = 72; RETURN -END IF -! Zero all weights that are approximately zero and renormalize the sum. -WHERE (X_DWNNLS < EPSL) X_DWNNLS = 0.0_R8 -X_DWNNLS(:) = X_DWNNLS(:) / SUM(X_DWNNLS) -! Compute the actual projection via matrix vector multiplication. -CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) -RNORML = DNRM2(D, PROJ(:) - Q(:,MI), 1) -RETURN -END SUBROUTINE PROJECT - -SUBROUTINE RESCALE(MINDIST, DIAMETER, SCALE) -! Rescale and transform data to be centered at the origin with unit -! radius. This subroutine has O(n^2) complexity. -! -! On output, PTS and Q have been rescaled and shifted. All the data -! points in PTS are centered with unit radius, and the points in Q -! have been shifted and scaled in relation to PTS. -! -! MINDIST is a real number containing the (scaled) minimum distance -! between any two data points in PTS. -! -! DIAMETER is a real number containing the (scaled) diameter of the -! data set PTS. -! -! SCALE contains the real factor used to transform the data and -! interpolation points: scaled value = (original value - -! barycenter of data points)/SCALE. - -! Output arguments. -REAL(KIND=R8), INTENT(OUT) :: MINDIST, DIAMETER, SCALE - -! Local variables. -REAL(KIND=R8) :: PTS_CENTER(D) ! The center of the data points PTS. -REAL(KIND=R8) :: DISTANCE ! The current distance. - -! Initialize local values. -MINDIST = HUGE(0.0_R8) -DIAMETER = 0.0_R8 -SCALE = 0.0_R8 - -! Compute barycenter of all data points. -PTS_CENTER(:) = SUM(PTS(:,:), DIM=2)/REAL(N, KIND=R8) -! Center the points. -FORALL (I = 1:N) PTS(:,I) = PTS(:,I) - PTS_CENTER(:) -! Compute the scale factor (for unit radius). -DO I = 1, N ! Cycle through all points again. - DISTANCE = DNRM2(D, PTS(:,I), 1) ! Compute the distance from the center. - IF (DISTANCE > SCALE) THEN ! Compare to the current radius. - SCALE = DISTANCE - END IF -END DO -! Scale the points to unit radius. -PTS = PTS / SCALE -! Also transform Q similarly. -FORALL (I = 1:M) Q(:,I) = (Q(:,I) - PTS_CENTER(:)) / SCALE -! Compute the minimum and maximum distances. -IF (EXACTL) THEN - ! If exact error error checking is turned on, then compute the DIAMETER - ! and MINDIST values. - DO I = 1, N ! Cycle through all pairs of points. - DO J = I + 1, N - DISTANCE = DNRM2(D, PTS(:,I) - PTS(:,J), 1) ! Compute the distance. - IF (DISTANCE > DIAMETER) THEN ! Compare to the current diameter. - DIAMETER = DISTANCE - END IF - IF (DISTANCE < MINDIST) THEN ! Compare to the current minimum distance. - MINDIST = DISTANCE - END IF - END DO - END DO -ELSE - ! If exact error checking is turned off, then the diameter is approximately - ! 2.0 after rescaling and centering the points. The MINDIST is not computed. - DIAMETER = 2.0_R8 - MINDIST = 1.0_R8 -END IF -RETURN -END SUBROUTINE RESCALE - -END SUBROUTINE DELAUNAYSPARSES - - -SUBROUTINE DELAUNAYSPARSEP( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EXACT, & - PMODE ) -! This is a parallel implementation of an algorithm for efficiently performing -! interpolation in R^D via the Delaunay triangulation. The algorithm is fully -! described and analyzed in -! -! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. -! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate -! interpolation in arbitrary dimension via the Delaunay triangulation. In -! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, -! USA. Article 12, 8 pages. -! -! -! On input: -! -! D is the dimension of the space for PTS and Q. -! -! N is the number of data points in PTS. -! -! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the -! coordinates of a single data point in R^D. -! -! M is the number of interpolation points in Q. -! -! Q(1:D,1:M) is a real valued matrix with M columns, each containing the -! coordinates of a single interpolation point in R^D. -! -! -! On output: -! -! PTS and Q have been rescaled and shifted. All the data points in PTS -! are now contained in the unit hyperball in R^D, and the points in Q -! have been shifted and scaled accordingly in relation to PTS. -! -! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns -! in PTS) for the D+1 vertices of the Delaunay simplex containing each -! interpolation point in Q. -! -! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each -! point in Q as a convex combination of the D+1 corresponding vertices -! in SIMPS. -! -! IERR(1:M) contains integer valued error flags associated with the -! computation of each of the M interpolation points in Q. The error -! codes are: -! -! 00 : Succesful interpolation. -! 01 : Succesful extrapolation (up to the allowed extrapolation distance). -! 02 : This point was outside the allowed extrapolation distance; the -! corresponding entries in SIMPS and WEIGHTS contain zero values. -! -! 10 : The dimension D must be positive. -! 11 : Too few data points to construct a triangulation (i.e., N < D+1). -! 12 : No interpolation points given (i.e., M < 1). -! 13 : The first dimension of PTS does not agree with the dimension D. -! 14 : The second dimension of PTS does not agree with the number of points N. -! 15 : The first dimension of Q does not agree with the dimension D. -! 16 : The second dimension of Q does not agree with the number of -! interpolation points M. -! 17 : The first dimension of the output array SIMPS does not match the number -! of vertices needed for a D-simplex (D+1). -! 18 : The second dimension of the output array SIMPS does not match the -! number of interpolation points M. -! 19 : The first dimension of the output array WEIGHTS does not match the -! number of vertices for a a D-simplex (D+1). -! 20 : The second dimension of the output array WEIGHTS does not match the -! number of interpolation points M. -! 21 : The size of the error array IERR does not match the number of -! interpolation points M. -! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. -! 23 : The first dimension of INTERP_IN does not match the first -! dimension of INTERP_OUT. -! 24 : The second dimension of INTERP_IN does not match the number of -! data points PTS. -! 25 : The second dimension of INTERP_OUT does not match the number of -! interpolation points M. -! 26 : The budget supplied in IBUDGET does not contain a positive -! integer. -! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. -! 28 : The size of the RNORM output array does not match the number of -! interpolation points M. -! -! 30 : Two or more points in the data set PTS are too close together with -! respect to the working precision (EPS), which would result in a -! numerically degenerate simplex. -! 31 : All the data points in PTS lie in some lower dimensional linear -! manifold (up to the working precision), and no valid triangulation -! exists. -! 40 : An error caused DELAUNAYSPARSEP to terminate before this value could -! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may -! contain garbage values. -! -! 50 : A memory allocation error occurred while allocating the work array -! WORK. -! -! 60 : The budget was exceeded before the algorithm converged on this -! value. If the dimension is high, try increasing IBUDGET. This -! error can also be caused by a working precision EPS that is too -! small for the conditioning of the problem. -! -! 61 : A value that was judged appropriate later caused LAPACK to encounter a -! singularity. Try increasing the value of EPS. -! -! 70 : Allocation error for the extrapolation work arrays. -! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection -! of an extrapolation point onto the convex hull. -! 72 : The SLATEC subroutine DWNNLS has reported a usage error. -! -! The errors 72, 80--83 should never occur, and likely indicate a -! compiler bug or hardware failure. -! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. -! 81 : The LAPACK subroutine DGETRF has reported an illegal value. -! 82 : The LAPACK subroutine DGETRS has reported an illegal value. -! 83 : The LAPACK subroutine DORMQR has reported an illegal value. -! -! 90 : The value of PMODE is not valid. -! -! -! Optional arguments: -! -! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of -! the data points in PTS on input. The first dimension of INTERP_IN is -! inferred to be the dimension of these response vectors, and the -! second dimension must match N. If present, the response values will -! be computed for each interpolation point in Q, and stored in INTERP_OUT, -! which therefore must also be present. If both INTERP_IN and INTERP_OUT -! are omitted, only the containing simplices and convex combination -! weights are returned. -! -! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each -! interpolation point in Q on output. The first dimension of INTERP_OU -! must match the first dimension of INTERP_IN, and the second dimension -! must match M. If present, the response values at each interpolation -! point are computed as a convex combination of the response values -! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing -! that interpolation point. Therefore, if INTERP_OUT is present, then -! INTERP_IN must also be present. If both are omitted, only the -! simplices and convex combination weights are returned. -! -! EPS contains the real working precision for the problem on input. By -! default, EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff -! for the machine. In general, any values that differ by less than EPS -! are judged as equal, and any weights that are greater than -EPS are -! judged as nonnegative. EPS cannot take a value less than the default -! value of \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, -! the default value will be used instead automatically. -! -! EXTRAP contains the real maximum extrapolation distance (relative to the -! diameter of PTS) on input. Interpolation at a point outside the convex -! hull of PTS is done by projecting that point onto the convex hull, and -! then doing normal Delaunay interpolation at that projection. -! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) -! units outside the convex hull of PTS will not be done and an error code -! of 2 will be returned. Note that computing the projection can be -! expensive. Setting EXTRAP=0 will cause all extrapolation points to be -! ignored without ever computing a projection. By default, EXTRAP=0.1 -! (extrapolate by up to 10% of the diameter of PTS). -! -! RNORM(1:M) contains the real unscaled projection (2-norm) distances from -! any projection computations on output. If not present, these distances -! are still computed for each extrapolation point, but are never returned. -! -! IBUDGET on input contains the integer budget for performing flips while -! iterating toward the simplex containing each interpolation point in Q. -! This prevents DELAUNAYSPARSEP from falling into an infinite loop when -! an inappropriate value of EPS is given with respect to the problem -! conditioning. By default, IBUDGET=50000. However, for extremely -! high-dimensional problems and pathological inputs, the default value -! may be insufficient. -! -! CHAIN is a logical input argument that determines whether a new first -! simplex should be constructed for each interpolation point -! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." -! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not -! recommended, unless the size of the triangulation is relatively small -! or the interpolation points are known to be tightly clustered. -! -! EXACT is a logical input argument that determines whether the exact -! diameter should be computed and whether a check for duplicate data -! points should be performed in advance. When EXACT=.FALSE., the -! diameter of PTS is approximated by twice the distance from the -! barycenter of PTS to the farthest point in PTS, and no check is -! done to find the closest pair of points, which could result in hard -! to find bugs later on. When EXACT=.TRUE., the exact diameter is -! computed and an error is returned whenever PTS contains duplicate -! values up to the precision EPS. By default EXACT=.TRUE., but setting -! EXACT=.FALSE. could result in significant speedup when N is large. -! It is strongly recommended that most users leave EXACT=.TRUE., as -! setting EXACT=.FALSE. could result in input errors that are difficult -! to identify. Also, the diameter approximation could be wrong by up to -! a factor of two. -! -! PMODE is an integer specifying the level of parallelism to be exploited. -! If PMODE = 1, then parallelism is exploited at the level of the loop -! over all interpolation points (Level 1 parallelism). -! If PMODE = 2, then parallelism is exploited at the level of the loops -! over data points when constructing/flipping simplices (Level 2 -! parallelism). -! If PMODE = 3, then parallelism is exploited at both levels. Note: this -! implies that the total number of threads active at any time could be up -! to OMP_NUM_THREADS^2. -! By default, PMODE is set to 1 if there is more than 1 interpolation -! point and 2 otherwise. -! -! -! Subroutines and functions directly referenced from BLAS are -! DDOT, DGEMV, DNRM2, DTRSM, -! and from LAPACK are -! DGEQP3, DGETRF, DGETRS, DORMQR. -! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its -! SLATEC dependencies have been slightly edited to comply with the Fortran -! 2008 standard, with all print statements and references to stderr being -! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 -! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS -! Algorithm 777) is used for the real data type. The REAL_PRECISION module, -! DELAUNAYSPARSEP, and DWNNLS and its dependencies comply with the Fortran -! 2008 standard. -! -! Primary Author: Tyler H. Chang -! Last Update: March, 2020 -! -USE REAL_PRECISION, ONLY : R8 -IMPLICIT NONE - -! Input arguments. -INTEGER, INTENT(IN) :: D, N -REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) ! Rescaled on output. -INTEGER, INTENT(IN) :: M -REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) ! Rescaled on output. -! Output arguments. -INTEGER, INTENT(OUT) :: SIMPS(:,:) -REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) -INTEGER, INTENT(OUT) :: IERR(:) -! Optional arguments. -REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) -REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) -REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP -REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) -INTEGER, INTENT(IN), OPTIONAL :: IBUDGET, PMODE -LOGICAL, INTENT(IN), OPTIONAL :: CHAIN -LOGICAL, INTENT(IN), OPTIONAL :: EXACT - -! Local copies of optional input arguments. -REAL(KIND=R8) :: EPSL, EXTRAPL -INTEGER :: IBUDGETL -LOGICAL :: CHAINL, EXACTL, PLVL1, PLVL2 - -! Local variables. -LOGICAL :: PTINSIMP ! Tells if Q(:,MI) is in SIMPS(:,MI). -INTEGER :: I, J, K ! Loop iteration variables. -INTEGER :: IEXTRAPS ! Extrapolation budget. -INTEGER :: IERR_PRIV ! Private copy of the error flag. -INTEGER :: ITMP, JTMP ! Temporary variables for swapping, looping, etc. -INTEGER :: LWORK ! Size of the work array. -INTEGER :: MI ! Index of current interpolation point. -INTEGER :: VERTEX_PRIV ! Private copy of next vertex to add. -REAL(KIND=R8) :: CURRRAD ! Radius of the current circumsphere. -REAL(KIND=R8) :: MINRAD ! Minimum circumsphere radius observed. -REAL(KIND=R8) :: MINRAD_PRIV ! Private copy of MINRAD. -REAL(KIND=R8) :: PTS_DIAM ! Scaled diameter of data set. -REAL(KIND=R8) :: PTS_SCALE ! Data scaling factor. -REAL(KIND=R8) :: RNORML ! Euclidean norm of the projection residual. -REAL(KIND=R8) :: SIDE1, SIDE2 ! Signs (+/-1) denoting sides of a facet. - -! Local arrays, requiring O(d^2) additional memory. -INTEGER :: IPIV(D) ! Pivot indices. -INTEGER :: SEED(D+1) ! Copy of the SEED simplex. Only used if CHAIN = .TRUE. -REAL(KIND=R8) :: AT(D,D) ! The transpose of A, the linear coefficient matrix. -REAL(KIND=R8) :: B(D) ! The RHS of a linear system. -REAL(KIND=R8) :: CENTER(D) ! The circumcenter of a simplex. -REAL(KIND=R8) :: CENTER_PRIV(D) ! Private copy of CENTER. -REAL(KIND=R8) :: LQ(D,D) ! Holds LU or QR factorization of AT. -REAL(KIND=R8) :: PLANE(D+1) ! The hyperplane containing a facet. -REAL(KIND=R8) :: PRGOPT_DWNNLS(1) ! Options array for DWNNLS. -REAL(KIND=R8) :: PROJ(D) ! The projection of the current iterate. -REAL(KIND=R8) :: TAU(D) ! Householder reflector constants. -REAL(KIND=R8) :: X(D) ! The solution to a linear system. - -! Extrapolation work arrays are only allocated if DWNNLS is called. -INTEGER, ALLOCATABLE :: IWORK_DWNNLS(:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: W_DWNNLS(:,:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: WORK(:) ! Allocated with size LWORK. -REAL(KIND=R8), ALLOCATABLE :: WORK_DWNNLS(:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: X_DWNNLS(:) ! Only for DWNNLS. - -! External functions and subroutines. -REAL(KIND=R8), EXTERNAL :: DDOT ! Inner product (BLAS). -REAL(KIND=R8), EXTERNAL :: DNRM2 ! Euclidean norm (BLAS). -EXTERNAL :: DGEMV ! General matrix vector multiply (BLAS) -EXTERNAL :: DGEQP3 ! Perform a QR factorization with column pivoting (LAPACK). -EXTERNAL :: DGETRF ! Perform a LU factorization with partial pivoting (LAPACK). -EXTERNAL :: DGETRS ! Use the output of DGETRF to solve a linear system (LAPACK). -EXTERNAL :: DORMQR ! Apply householder reflectors to a matrix (LAPACK). -EXTERNAL :: DTRSM ! Perform a triangular solve (BLAS). -EXTERNAL :: DWNNLS ! Solve an inequality constrained least squares problem - ! (SLATEC). - -! Check for input size and dimension errors. -IF (D < 1) THEN ! The dimension must satisfy D > 0. - IERR(:) = 10; RETURN; END IF -IF (N < D+1) THEN ! Must have at least D+1 data points. - IERR(:) = 11; RETURN; END IF -IF (M < 1) THEN ! Must have at least one interpolation point. - IERR(:) = 12; RETURN; END IF -IF (SIZE(PTS,1) .NE. D) THEN ! Dimension of PTS array should match. - IERR(:) = 13; RETURN; END IF -IF (SIZE(PTS,2) .NE. N) THEN ! Number of data points should match. - IERR(:) = 14; RETURN; END IF -IF (SIZE(Q,1) .NE. D) THEN ! Dimension of Q should match. - IERR(:) = 15; RETURN; END IF -IF (SIZE(Q,2) .NE. M) THEN ! Number of interpolation points should match. - IERR(:) = 16; RETURN; END IF -IF (SIZE(SIMPS,1) .NE. D+1) THEN ! Need space for D+1 vertices per simplex. - IERR(:) = 17; RETURN; END IF -IF (SIZE(SIMPS,2) .NE. M) THEN ! There will be M output simplices. - IERR(:) = 18; RETURN; END IF -IF (SIZE(WEIGHTS,1) .NE. D+1) THEN ! There will be D+1 weights per simplex. - IERR(:) = 19; RETURN; END IF -IF (SIZE(WEIGHTS,2) .NE. M) THEN ! One vector of weights per simplex. - IERR(:) = 20; RETURN; END IF -IF (SIZE(IERR) .NE. M) THEN ! An error flag for each interpolation point. - IERR(:) = 21; RETURN; END IF - -! Check for optional arguments. -IF (PRESENT(INTERP_IN) .NEQV. PRESENT(INTERP_OUT)) THEN - IERR(:) = 22; RETURN; END IF -IF (PRESENT(INTERP_IN)) THEN ! Sizes must agree. - IF (SIZE(INTERP_IN,1) .NE. SIZE(INTERP_OUT,1)) THEN - IERR(:) = 23 ; RETURN; END IF - IF(SIZE(INTERP_IN,2) .NE. N) THEN - IERR(:) = 24; RETURN; END IF - IF (SIZE(INTERP_OUT,2) .NE. M) THEN - IERR(:) = 25; RETURN; END IF - INTERP_OUT(:,:) = 0.0_R8 ! Initialize output to zeros. -END IF -EPSL = SQRT(EPSILON(0.0_R8)) ! Get the machine unit roundoff constant. -IF (PRESENT(EPS)) THEN - IF (EPSL < EPS) THEN ! If the given precision is too small, ignore it. - EPSL = EPS - END IF -END IF -IF (PRESENT(IBUDGET)) THEN - IBUDGETL = IBUDGET ! Use the given budget if present. - IF (IBUDGETL < 1) THEN - IERR(:) = 26; RETURN; END IF -ELSE - IBUDGETL = 50000 ! Default value for budget. -END IF -IF (PRESENT(EXTRAP)) THEN - EXTRAPL = EXTRAP - IF (EXTRAPL < 0) THEN ! Check that the extrapolation distance is legal. - IERR(:) = 27; RETURN; END IF -ELSE - EXTRAPL = 0.1_R8 ! Default extrapolation distance (for normalized points). -END IF -IF (PRESENT(RNORM)) THEN - IF (SIZE(RNORM,1) .NE. M) THEN ! The length of the array must match. - IERR(:) = 28; RETURN; END IF - RNORM(:) = 0.0_R8 ! Initialize output to zeros. -END IF -IF (PRESENT(CHAIN)) THEN - CHAINL = CHAIN ! Turn chaining on, if necessarry. - SEED(:) = 0 ! Initialize SEED in case it is needed. -ELSE - CHAINL = .FALSE. -END IF -IF (PRESENT(EXACT)) THEN - EXACTL = EXACT ! Set error checking and exact diameter computations. -ELSE - EXACTL = .TRUE. -END IF -! Set the PMODE. -PLVL1 = .FALSE. -PLVL2 = .FALSE. -IF (PRESENT(PMODE)) THEN ! Check PMODE for legal values. - IF (PMODE .EQ. 1) THEN - PLVL1 = .TRUE. - ELSE IF (PMODE .EQ. 2) THEN - PLVL2 = .TRUE. - ELSE IF (PMODE .EQ. 3) THEN - PLVL1 = .TRUE.; PLVL2 = .TRUE. - ELSE - IERR(:) = 90; RETURN - END IF -ELSE ! The default setting for PMODE is level 1 parallelism if M > 1. - IF (M > 1) THEN - PLVL1 = .TRUE. - ELSE - PLVL2 = .TRUE. - END IF -END IF - -! Scale and center the data points and interpolation points. -CALL RESCALE(MINRAD, PTS_DIAM, PTS_SCALE) -IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. - IERR(:) = 30; RETURN; END IF - -! Query DGEQP3 for optimal work array size (LWORK). -LWORK = -1 -CALL DGEQP3(D,D,LQ,D,IPIV,TAU,B,LWORK,IERR(1)) -LWORK = INT(B(1)) ! Compute the optimal work array size. -ALLOCATE(WORK(LWORK), STAT=I) ! Allocate WORK to size LWORK. -IF (I .NE. 0) THEN ! Check for memory allocation errors. - IERR(:) = 50; RETURN; END IF - -! Initialize PRGOPT_DWNNLS in case of extrapolation. -PRGOPT_DWNNLS(1) = 1.0_R8 - -! Initialize all error codes to "TBD" values. -IERR(:) = 40 - -! Begin level 1 parallel region (over all interpolation points in Q). -!$OMP PARALLEL & -! -! The FIRSTPRIVATE list specifies initialized variables, of which each -! thread has a private copy. -!$OMP& FIRSTPRIVATE(SEED), & -! -! The PRIVATE list specifies uninitialized variables, of which each -! thread has a private copy. -!$OMP& PRIVATE(I, J, K, IEXTRAPS, ITMP, JTMP, CURRRAD, MI, MINRAD, & -!$OMP& RNORML, SIDE1, SIDE2, IERR_PRIV, VERTEX_PRIV, MINRAD_PRIV, & -!$OMP& PTINSIMP, IPIV, AT, B, CENTER, CENTER_PRIV, LQ, PLANE, & -!$OMP& PROJ, TAU, WORK, X, IWORK_DWNNLS, W_DWNNLS, WORK_DWNNLS, & -!$OMP& X_DWNNLS), & -! -! Any variables not explicitly listed above receive the SHARED scope -! by default and are visible across all threads. -!$OMP& DEFAULT(SHARED), & -! -!$OMP& IF(PLVL1) -!$OMP DO SCHEDULE(DYNAMIC) -OUTER : DO MI = 1, M - !$OMP CRITICAL(CHECK_IERR) - ! Check if this interpolation point was already found. - IF (IERR(MI) .EQ. 40) THEN - IERR(MI) = 0 - IERR_PRIV = 0 - ELSE - IERR_PRIV = -1 - END IF - !$OMP END CRITICAL(CHECK_IERR) - IF(IERR_PRIV .EQ. -1) CYCLE OUTER - - ! Initialize the projection and reset the residual. - PROJ(:) = Q(:,MI) - RNORML = 0.0_R8 - - ! Check if extrapolation is enabled. - IF (EXTRAPL < EPSL) THEN - IEXTRAPS = -1 ! If not, set the extrapolation budget negative. - ELSE - IEXTRAPS = 1 ! Allow for exactly one projection for this point. - END IF - - ! If there is no useable seed or if chaining is turned off, then make a new - ! simplex. - IF( (.NOT. CHAINL) .OR. SEED(1) .EQ. 0) THEN -! CALL MAKEFIRSTSIMP(); IF(IERR_PRIV .NE. 0) CYCLE OUTER - - -!****************************************************************************** -! Due to OpenMP's handling of variable scope, the parallel implementation of -! the subroutine MAKEFIRSTSIMP() has been in-lined here. -! -! SUBROUTINE MAKEFIRSTSIMP() -! -! Iteratively construct the first simplex by choosing points that -! minimize the radius of the smallest circumball. Let P_1, P_2, ..., P_K -! denote the current list of vertices for the simplex. Let P* denote the -! candidate vertex to be added to the simplex. Let CENTER denote the -! circumcenter of the simplex. Then -! -! X = CENTER - P_1 -! -! is given by the minimum norm solution to the underdetermined linear system -! -! A X = B, where -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_K - P_1, P* - P_1 ] and -! B = [ /2, /2, ..., /2 ]^T. -! -! Then the radius of the smallest circumsphere is CURRRAD = \| X \|, -! and the next vertex is given by P_{K+1} = argmin_{P*} CURRRAD, where P* -! ranges over points in PTS that are not already a vertex of the simplex. -! -! On output, this subroutine fully populates the matrix A^T and vector B, -! and fills SIMPS(:,MI) with the indices of a valid Delaunay simplex. - -! Initialize simplex and shared variables. -SIMPS(:,MI) = 0 -MINRAD_PRIV = HUGE(0.0_R8) -MINRAD = HUGE(0.0_R8) - -! Below is a Level 2 parallel region over N points in PTS to find the -! first and second vertices SIMPS(1,MI) and SIMPS(2,MI). -!$OMP PARALLEL & -! -! The FIRSTPRIVATE list specifies initialized variables, of which each -! thread has a private copy. -!$OMP& FIRSTPRIVATE(MINRAD_PRIV), & -! -! The PRIVATE list specifies uninitialized variables, of which each -! thread has a private copy. -!$OMP& PRIVATE(I, CURRRAD, VERTEX_PRIV), & -! -! Any variables not explicitly listed above receive the SHARED scope -! by default and are visible across all threads. -!$OMP& DEFAULT(SHARED), & -! -!$OMP& IF(PLVL2) -! Find the first point, i.e., the closest point to Q(:,MI). -!$OMP DO SCHEDULE(STATIC) -DO I = 1, N - ! Check the distance to Q(:,MI) - CURRRAD = DNRM2(D, PTS(:,I) - PROJ(:), 1) - IF (CURRRAD < MINRAD_PRIV) THEN - MINRAD_PRIV = CURRRAD; VERTEX_PRIV = I; - END IF -END DO -!$OMP END DO -!$OMP CRITICAL(REDUC_1) -IF (MINRAD_PRIV < MINRAD) THEN - MINRAD = MINRAD_PRIV; SIMPS(1,MI) = VERTEX_PRIV; -END IF -!$OMP END CRITICAL(REDUC_1) -! Find the second point, i.e., the closest point to PTS(:,SIMPS(1,MI)). -MINRAD_PRIV = HUGE(0.0_R8) -!$OMP BARRIER -!$OMP SINGLE -MINRAD = HUGE(0.0_R8) -!$OMP END SINGLE -!$OMP DO SCHEDULE(STATIC) -DO I = 1, N - ! Skip repeated vertices. - IF (I .EQ. SIMPS(1,MI)) CYCLE - ! Check the diameter of the resulting circumsphere. - CURRRAD = DNRM2(D, PTS(:,I)-PTS(:,SIMPS(1,MI)), 1) - IF (CURRRAD < MINRAD_PRIV) THEN - MINRAD_PRIV = CURRRAD; VERTEX_PRIV = I - END IF -END DO -!$OMP END DO -!$OMP CRITICAL(REDUC_2) -IF (MINRAD_PRIV < MINRAD) THEN - MINRAD = MINRAD_PRIV; SIMPS(2,MI) = VERTEX_PRIV -END IF -!$OMP END CRITICAL(REDUC_2) -!$OMP END PARALLEL -! This is the end of the Level 2 parallel block. -IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. - IERR(MI) = 30; CYCLE OUTER; END IF - -! Set up the first row of the system A X = B. -AT(:,1) = PTS(:,SIMPS(2,MI)) - PTS(:,SIMPS(1,MI)) -B(1) = DDOT(D, AT(:,1), 1, AT(:,1), 1) / 2.0_R8 - -! Loop to collect the remaining D-1 vertices for the first simplex. -DO I = 2, D - ! Compute A^T P = Q R for the current matrix A^T. - LQ(:,1:I-1) = AT(:,1:I-1) - CALL DGEQP3(D, I-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 80 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Set the RHS to P^T B. - FORALL (ITMP = 1:I-1) X(ITMP) = B(IPIV(ITMP)) - ! Solve R^T Q^T X = P^T B for Q^T X, and save for later. - CALL DTRSM('L', 'U', 'T', 'N', I-1, 1, 1.0_R8, LQ, D, X, D) - ! Make a copy for computing the current center. - CENTER(1:I-1) = X(1:I-1) - CENTER(I:D) = 0.0_R8 - ! Apply Q from the left. - CALL DORMQR('L', 'N', D, 1, I-1, LQ, D, TAU, CENTER, D, WORK, & - LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 83 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - CENTER = CENTER + PTS(:,SIMPS(1,MI)) - ! Re-initialize the radius for each iteration. - MINRAD = HUGE(0.0_R8) - MINRAD_PRIV = HUGE(0.0_R8) - VERTEX_PRIV = 0 - - ! This is another Level 2 parallel block over N points in PTS. - !$OMP PARALLEL & - ! - ! The FIRSTPRIVATE list specifies initialized variables, of which each - ! thread has a private copy. - !$OMP& FIRSTPRIVATE(LQ, MINRAD_PRIV, VERTEX_PRIV, X), & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(J, CURRRAD, WORK), & - ! - ! The REDUCTION clause specifies a PRIVATE variable that will retain - ! some value (i.e., max, min, sum, etc.) upon output. - !$OMP& REDUCTION(MAX:IERR_PRIV), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& IF(PLVL2) - - ! Initialize the error flag. - IERR_PRIV = 0 - !$OMP DO SCHEDULE(STATIC) - DO J = 1, N - IF (IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. - ! Check that this point is not already in the simplex. - IF (ANY(SIMPS(:,MI) .EQ. J)) CYCLE - ! If PTS(:,J) is more than twice MINRAD_PRIV from CENTER, do a quick skip. - IF (DNRM2(D, CENTER - PTS(:,J), 1) > 2.0_R8 * MINRAD_PRIV) CYCLE - ! Perform a rank-1 update to the current QR factorization of A^T by - ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the - ! final column of R. - LQ(:,I) = PTS(:,J) - PTS(:,SIMPS(1,MI)) - CALL DORMQR('L', 'T', D, 1, I-1, LQ(:,1:I-1), D, TAU, LQ(:,I), D, & - WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - IERR_PRIV = 83; CYCLE - END IF - ! Implicitly apply the next Householder reflector. - LQ(I,I) = DNRM2(D+1-I, LQ(I:D,I), 1) - IF (LQ(I,I) < EPSL) THEN ! A is rank-deficient. - CYCLE ! If rank-deficient, skip this point. - END IF - ! Update the current radius by \| Q^T X \| = \| X \|. - WORK(1:I-1) = (LQ(1:I-1,I) / 2.0_R8) - X(1:I-1) - WORK(I) = LQ(I,I) / 2.0_R8 - X(I) = DDOT(I, LQ(1:I,I), 1, WORK(1:I), 1) / LQ(I,I) - CURRRAD = DNRM2(I, X(1:I), 1) - ! Compare the last component of Q^T X to the current minimum. - IF (CURRRAD < MINRAD_PRIV) THEN - MINRAD_PRIV = CURRRAD; VERTEX_PRIV = J - END IF - END DO - !$OMP END DO - !$OMP CRITICAL(REDUC_3) - IF (MINRAD_PRIV < MINRAD) THEN - MINRAD = MINRAD_PRIV; SIMPS(I+1,MI) = VERTEX_PRIV - END IF - !$OMP END CRITICAL(REDUC_3) - !$OMP END PARALLEL - ! End of Level 2 parallel block. - - ! Check the final error flag. - IF (IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = IERR_PRIV - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Check that a point was found. If not, then all the points must lie in a - ! lower dimensional linear manifold (error case). - IF (SIMPS(I+1,MI) .EQ. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 31 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! If all operations were successful, add the best P* to the linear system. - AT(:,I) = PTS(:,SIMPS(I+1,MI)) - PTS(:,SIMPS(1,MI)) - B(I) = DDOT(D, AT(:,I), 1, AT(:,I), 1) / 2.0_R8 -END DO -! RETURN -! END SUBROUTINE MAKEFIRSTSIMP -! This marks the end of the in-lined MAKEFIRSTSIMP() subroutine call. -!****************************************************************************** - - - ! Otherwise, use the seed. - ELSE - ! Copy the seed to the current simplex. - SIMPS(:,MI) = SEED(:) - ! Rebuild the linear system. - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - - ! Inner loop searching for a simplex containing the point Q(:,MI). - INNER : DO K = 1, IBUDGETL - - ! If chaining is on, save each good simplex as the next seed. - IF (CHAINL) SEED(:) = SIMPS(:,MI) - - -!****************************************************************************** -! Due to OpenMP's handling of variable scope, the parallel implementation of -! the subroutine PTINSIMP() has been in-lined here. -! -! FUNCTION PTINSIMP() RESULT(TF) -! Determine if any interpolation points are in the current simplex, whose -! vertices (P_1, P_2, ..., P_{D+1}) are indexed by SIMPS(:,MI). These -! vertices determine a positive cone with generators V_I = P_{I+1} - P_1, -! I = 1, ..., D. For each interpolation point Q* in Q, Q* - P_1 can be -! expressed as a unique linear combination of the V_I. If all these linear -! weights are nonnegative and sum to less than or equal to 1.0, then Q* is -! in the simplex with vertices {P_I}_{I=1}^{D+1}. -! -! If any interpolation points in Q are contained in the simplex whose -! vertices are indexed by SIMPS(:,MI), then those points are marked as solved -! and the values of SIMPS and WEIGHTS are updated appropriately. On output, -! WEIGHTS(:,MI) contains the affine weights for producing Q(:,MI) as an -! affine combination of the points in PTS indexed by SIMPS(:,MI). If these -! weights are nonnegative, then PTINSIMP() returns TRUE. - -! Initialize the return value and local variables. -PTINSIMP = .FALSE. - -! Compute the LU factorization of the matrix A^T, whose columns are -! P_{I+1} - P_1. -LQ = AT -CALL DGETRF(D, D, LQ, D, IPIV, IERR_PRIV) -IF (IERR_PRIV < 0) THEN ! LAPACK illegal input. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 81 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER -ELSE IF (IERR_PRIV > 0) THEN ! Rank-deficiency detected. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 61 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER -END IF -! Solve A^T w = WORK to get the affine weights for Q(:,MI) or its projection. -WORK(1:D) = PROJ(:) - PTS(:,SIMPS(1,MI)) -CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(1:D), D, IERR_PRIV) -IF (IERR_PRIV < 0) THEN ! LAPACK illegal input. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 82 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER -END IF -WEIGHTS(2:D+1,MI) = WORK(1:D) -WEIGHTS(1,MI) = 1.0_R8 - SUM(WEIGHTS(2:D+1,MI)) -! Check if the weights for Q(:,MI) are nonnegative. -IF (ALL(WEIGHTS(:,MI) .GE. -EPSL)) PTINSIMP = .TRUE. - -! If Level 1 parallelism is active, do not parallelize this loop. -IF (PLVL1) THEN - ! Loop over all remaining unsolved interoplation points. Uses PLANE(:) - ! as a work array. - DO I = MI+1, M - ! Check that no solution has already been found. - !$OMP CRITICAL(CHECK_IERR) - ITMP = IERR(I) - !$OMP END CRITICAL(CHECK_IERR) - IF (ITMP .NE. 40) CYCLE - ! Solve A^T w = PLANE to get the affine weights for Q(:,I). - PLANE(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) - CALL DGETRS('N', D, 1, LQ, D, IPIV, PLANE(2:D+1), D, ITMP) - IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. - ! Check if the weights define a convex combination. - PLANE(1) = 1.0_R8 - SUM(PLANE(2:D+1)) - IF (ALL(PLANE(1:D+1) .GE. -EPSL)) THEN - !$OMP CRITICAL(CHECK_IERR) - IF(IERR(I) .EQ. 40) THEN - ! Copy the simplex indices and weights then flag as complete. - SIMPS(:,I) = SIMPS(:,MI) - WEIGHTS(:,I) = PLANE(1:D+1) - IERR(I) = 0 - END IF - !$OMP END CRITICAL(CHECK_IERR) - END IF - END DO -! If Level 1 parallelism is not active, there will be no conflicts for -! parallelizing this loop. -ELSE - ! Level 2 parallel block over all remaining unsolved interoplation - ! points. Uses PLANE(:) as a work array. - !$OMP PARALLEL DO & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(I, PLANE, ITMP), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& SCHEDULE(STATIC), & - !$OMP& IF(PLVL2) - DO I = MI+1, M - ! Check that no solution has already been found. - IF (IERR(I) .NE. 40) CYCLE - ! Solve A^T w = PLANE to get the affine weights for Q(:,I). - PLANE(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) - CALL DGETRS('N', D, 1, LQ, D, IPIV, PLANE(2:D+1), D, ITMP) - IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. - ! Check if the weights define a convex combination. - PLANE(1) = 1.0_R8 - SUM(PLANE(2:D+1)) - IF (ALL(PLANE(1:D+1) .GE. -EPSL)) THEN - ! Copy the simplex indices and weights then flag as complete. - SIMPS(:,I) = SIMPS(:,MI) - WEIGHTS(:,I) = PLANE(1:D+1) - IERR(I) = 0 - END IF - END DO - !$OMP END PARALLEL DO -END IF -! End of Level 2 parallel block. -! RETURN -! END FUNCTION PTINSIMP -! This marks the end of the in-lined PTINSIMP() subroutine call. -!****************************************************************************** - - - ! Check if the current simplex contains Q(:,MI). - IF (PTINSIMP) EXIT INNER - - ! Swap out the least weighted vertex, but save its value in case it - ! needs to be restored later. - JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) - ITMP = SIMPS(JTMP,MI) - SIMPS(JTMP,MI) = SIMPS(D+1,MI) - - ! If the least weighted vertex (index JTMP) is not the first vertex, - ! then just drop row (JTMP-1) from the linear system (corresponding - ! to column (JTMP-1) of A^T). - IF(JTMP .NE. 1) THEN - AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) - ! However, if JTMP = 1, then both A^T and B must be reconstructed. - ELSE - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - - ! Compute the next simplex (do one flip). -! CALL MAKESIMPLEX(); IF (IERR_PRIV .NE. 0) CYCLE OUTER - - -!****************************************************************************** -! Due to OpenMP's handling of variable scope, the parallel implementation of -! the subroutine MAKESIMPLEX() has been in-lined here. -! -! SUBROUTINE MAKESIMPLEX() -! Given a Delaunay facet F whose containing hyperplane does not contain -! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' -! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F -! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the -! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly -! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing -! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices -! P_1, P_2, ..., P_D, P*. Then -! -! X = CENTER - P_1 -! -! is given by the solution to the nonsingular linear system -! -! A X = B where -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and -! B = [ /2, /2, ..., /2 ]^T. -! -! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the -! candidate P* that satisfies both of the following: -! -! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) -! must be on the same side of PLANE. -! -! 2) The circumball about CENTER must not contain any points in PTS in its -! interior (Delaunay property). -! -! The above are necessary and sufficient conditions for flipping the -! Delaunay simplex, given that F is indeed a Delaunay facet. -! -! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices -! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex -! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and -! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were -! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an -! extrapolation point (not a convex combination of points in PTS). - -! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed -! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. -! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal -! vector is any nonzero vector in ker A, where the matrix -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. -! -! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR -! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. -! Then the last column of Q is orthogonal to the range of A^T, and in ker A. -IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. - ! Compute the QR factorization. - IPIV=0 - LQ = AT - CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 80 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! The nullspace is given by the last column of Q. - PLANE(1:D-1) = 0.0_R8 - PLANE(D) = 1.0_R8 - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & - LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 83 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Calculate the constant \alpha defining the plane. - PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) - ! Compute the sign for the side of PLANE containing Q(:,MI). - SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) - SIDE1 = SIGN(1.0_R8,SIDE1) - - ! Set the RHS to P^T B. - FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) - ! Solve R^T Q^T X = P^T B for Q^T X. - CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) - - ! Initialize the center, radius, simplex, and OpenMP variabls. - SIMPS(D+1,MI) = 0 - CENTER(:) = 0.0_R8 - CENTER_PRIV(:) = 0.0_R8 - MINRAD = HUGE(0.0_R8) - MINRAD_PRIV = HUGE(0.0_R8) - VERTEX_PRIV = 0 - - ! Begin Level 2 parallel loop over N points in PTS. - !$OMP PARALLEL & - ! - ! The FIRSTPRIVATE list specifies initialized variables, of which each - ! thread has a private copy. - !$OMP& FIRSTPRIVATE(CENTER_PRIV, LQ, MINRAD_PRIV, VERTEX_PRIV), & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(I, SIDE2, WORK), & - ! - ! The REDUCTION clause specifies a PRIVATE variable that will retain - ! some value (i.e., max, min, sum, etc.) upon output. - !$OMP& REDUCTION(MAX:IERR_PRIV), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& IF(PLVL2) - - ! Initialize the error flag. - IERR_PRIV = 0 - !$OMP DO SCHEDULE(STATIC) - DO I = 1, N - IF(IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. - ! Check that P* is inside the current ball. - IF (DNRM2(D, PTS(:,I) - CENTER_PRIV(:), 1) > MINRAD_PRIV) CYCLE - ! Check that P* is on the appropriate halfspace. - SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) - IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE - ! Perform a rank-1 update to the current QR factorization of A^T by - ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the - ! final column of R. - LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) - CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & - LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - IERR_PRIV = 83; CYCLE - END IF - ! Update the last element of Q^T X. - WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) - WORK(D) = LQ(D,D) / 2.0_R8 - CENTER_PRIV(1:D-1) = X(1:D-1) - CENTER_PRIV(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) - ! Get the center by applying Q to the solution. - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER_PRIV, D, & - WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - IERR_PRIV = 83; CYCLE - END IF - ! Update the new radius, center, and simplex. - MINRAD_PRIV = DNRM2(D, CENTER_PRIV, 1) - CENTER_PRIV(:) = CENTER_PRIV(:) + PTS(:,SIMPS(1,MI)) - VERTEX_PRIV = I - END DO - !$OMP END DO - !$OMP CRITICAL(REDUC_4) - ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. - IF (VERTEX_PRIV .NE. 0) THEN - IF (DNRM2(D, PTS(:,VERTEX_PRIV) - CENTER(:), 1) < MINRAD) THEN - MINRAD = MINRAD_PRIV - CENTER(:) = CENTER_PRIV(:) - SIMPS(D+1,MI) = VERTEX_PRIV - END IF - END IF - !$OMP END CRITICAL(REDUC_4) - !$OMP END PARALLEL - ! End level 2 parallel region. - - ! Check for error flags. - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = IERR_PRIV - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Check for extrapolation condition. - IF(SIMPS(D+1,MI) .NE. 0) THEN - ! Add new point to the linear system. - AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - END IF -ELSE ! Special case where D=1. - PLANE(1) = 1.0_R8 - PLANE(2) = PTS(1,SIMPS(1,MI)) - SIDE1 = SIGN(1.0_R8, PROJ(1) - PLANE(2)) - ! Initialize the radius, simplex, and OpenMP variabls. - SIMPS(2,MI) = 0 - MINRAD = HUGE(0.0_R8) - MINRAD_PRIV = HUGE(0.0_R8) - VERTEX_PRIV = 0 - ! Begin Level 2 parallel loop over N points in PTS. - !$OMP PARALLEL & - ! - ! The FIRSTPRIVATE list specifies initialized variables, of which each - ! thread has a private copy. - !$OMP& FIRSTPRIVATE(MINRAD_PRIV, VERTEX_PRIV), & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(I, SIDE2), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& IF(PLVL2) - - !$OMP DO SCHEDULE(STATIC) - DO I = 1, N - ! Check that P* is on the appropriate halfspace. - SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 - IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE - ! Check that P* is closer than the current solution. - IF (SIDE2 > MINRAD) CYCLE - ! Update the minimum distance and save the index I. - MINRAD_PRIV = SIDE2 - VERTEX_PRIV = I - END DO - !$OMP END DO - !$OMP CRITICAL(REDUC_4) - ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. - IF (VERTEX_PRIV .NE. 0) THEN - IF (MINRAD_PRIV < MINRAD) THEN - MINRAD = MINRAD_PRIV - SIMPS(2,MI) = VERTEX_PRIV - END IF - END IF - !$OMP END CRITICAL(REDUC_4) - !$OMP END PARALLEL - ! Check for extrapolation condition. - IF(SIMPS(2,MI) .NE. 0) THEN - ! Add new point to the linear system. - AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) - B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 - END IF -END IF -! RETURN -! END SUBROUTINE MAKESIMPLEX -! End of in-lined code for MAKESIMPLEX(). -!****************************************************************************** - - - ! If no vertex was found, then this is an extrapolation point. - IF (SIMPS(D+1,MI) .EQ. 0) THEN - ! If extrapolation is not allowed (EXTRAP=0), do not proceed. - IF (IEXTRAPS < 0) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! Set the error flag and skip this point. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 2 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - - ! If extrapolation is allowed (EXTRAP>0), check the budget. - ELSE IF (IEXTRAPS .EQ. 0) THEN - ! A second projection has been attempted. This code is rarely - ! called, except in extreme cases involving nearly singular - ! simplices near the convex hull of P. - - ! Swap the weights to match the simplex indices, and zero the - ! most negative weight. - !$OMP CRITICAL(CHECK_IERR) - WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) - WEIGHTS(D+1,MI) = 0.0_R8 - !$OMP END CRITICAL(CHECK_IERR) - ! Loop through all the remaining facets from which Q(:,MI) is - ! visible, and attempt to flip across each one. - DO WHILE (SIMPS(D+1,MI) .EQ. 0) - ! Restore the previous simplex and linear system. - SIMPS(D+1,MI) = ITMP - AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - ! Find the next most negative weight. - JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) - ! Check if WEIGHTS(JTMP,MI) .GE. 0. - IF (WEIGHTS(JTMP,MI) .GE. -EPSL) THEN - ! There is no other direction to flip, so Q(:,MI) must be - ! within EPSL of the current simplex. - ! Project Q(:,MI) onto the current simplex. - - ! Since at least one projection has already been done, - ! the work arrays have already been allocated. - PRGOPT_DWNNLS(1) = 1.0_R8 - IWORK_DWNNLS(1) = 6*D + 6 - IWORK_DWNNLS(2) = 2*D + 2 - ! Set equality constraint. - W_DWNNLS(1,1:D+2) = 1.0_R8 - ! Populate LS coefficient matrix and RHS. - FORALL (I=1:D+1) W_DWNNLS(2:D+1,I) = PTS(:,SIMPS(I,MI)) - W_DWNNLS(2:D+1,D+2) = PROJ(:) - ! Project onto the current simplex. - CALL DWNNLS(W_DWNNLS, D+1, 1, D, D+1, 0, PRGOPT_DWNNLS, & - WEIGHTS(:,MI), WORK(1), IERR_PRIV, IWORK_DWNNLS, & - WORK_DWNNLS) - IF (IERR_PRIV .EQ. 1) THEN ! Failure to converge. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 71 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - ELSE IF (IERR_PRIV .EQ. 2) THEN ! Illegal input detected. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 72 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! A solution has been found; return it. - EXIT INNER - END IF - ! Otherwise, swap the vertices. - ITMP = SIMPS(JTMP,MI) - SIMPS(JTMP,MI) = SIMPS(D+1,MI) - ! Swap the weights to match, and zero the most negative weight. - !$OMP CRITICAL(CHECK_IERR) - WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) - WEIGHTS(D+1,MI) = 0.0_R8 - !$OMP END CRITICAL(CHECK_IERR) - ! If the least weighted vertex (index JTMP) is not the first vertex, - ! then just drop row (JTMP-1) from the linear system - ! (corresponding to the JTMP-1st column of A^T). - IF (JTMP .NE. 1) THEN - AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) - ! However, if JTMP=1, then both A^T and B must be reconstructed. - ELSE - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - ! Compute another simplex (try to flip again). -! CALL MAKESIMPLEX(); IF (IERR(MI) .NE. 0) CYCLE OUTER - - -!****************************************************************************** -! Due to OpenMP's handling of variable scope, the parallel implementation of -! the subroutine MAKESIMPLEX() has been in-lined here. -! -! SUBROUTINE MAKESIMPLEX() -! Given a Delaunay facet F whose containing hyperplane does not contain -! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' -! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F -! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the -! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly -! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing -! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices -! P_1, P_2, ..., P_D, P*. Then -! -! X = CENTER - P_1 -! -! is given by the solution to the nonsingular linear system -! -! A X = B where -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and -! B = [ /2, /2, ..., /2 ]^T. -! -! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the -! candidate P* that satisfies both of the following: -! -! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) -! must be on the same side of PLANE. -! -! 2) The circumball about CENTER must not contain any points in PTS in its -! interior (Delaunay property). -! -! The above are necessary and sufficient conditions for flipping the -! Delaunay simplex, given that F is indeed a Delaunay facet. -! -! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices -! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex -! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and -! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were -! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an -! extrapolation point (not a convex combination of points in PTS). - -! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed -! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. -! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal -! vector is any nonzero vector in ker A, where the matrix -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. -! -! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR -! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. -! Then the last column of Q is orthogonal to the range of A^T, and in ker A. -IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. - ! Compute the QR factorization. - IPIV=0 - LQ = AT - CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 80 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! The nullspace is given by the last column of Q. - PLANE(1:D-1) = 0.0_R8 - PLANE(D) = 1.0_R8 - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & - LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 83 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Calculate the constant \alpha defining the plane. - PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) - ! Compute the sign for the side of PLANE containing Q(:,MI). - SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) - SIDE1 = SIGN(1.0_R8,SIDE1) - ! Set the RHS to P^T B. - FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) - ! Solve R^T Q^T X = P^T B for Q^T X. - CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) - ! Initialize the center, radius, simplex, and OpenMP variabls. - SIMPS(D+1,MI) = 0 - CENTER(:) = 0.0_R8 - CENTER_PRIV(:) = 0.0_R8 - MINRAD = HUGE(0.0_R8) - MINRAD_PRIV = HUGE(0.0_R8) - VERTEX_PRIV = 0 - - ! Begin Level 2 parallel loop over N points in PTS. - !$OMP PARALLEL & - ! - ! The FIRSTPRIVATE list specifies initialized variables, of which each - ! thread has a private copy. - !$OMP& FIRSTPRIVATE(CENTER_PRIV, LQ, MINRAD_PRIV, VERTEX_PRIV), & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(I, SIDE2, WORK), & - ! - ! The REDUCTION clause specifies a PRIVATE variable that will retain - ! some value (i.e., max, min, sum, etc.) upon output. - !$OMP& REDUCTION(MAX:IERR_PRIV), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& IF(PLVL2) - - ! Initialize the error flag. - IERR_PRIV = 0 - !$OMP DO SCHEDULE(STATIC) - DO I = 1, N - IF(IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. - ! Check that P* is inside the current ball. - IF (DNRM2(D, PTS(:,I) - CENTER_PRIV(:), 1) > MINRAD_PRIV) CYCLE - ! Check that P* is on the appropriate halfspace. - SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) - IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE - ! Perform a rank-1 update to the current QR factorization of A^T by - ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the - ! final column of R. - LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) - CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & - LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - IERR_PRIV = 83; CYCLE - END IF - ! Update the last element of Q^T X. - WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) - WORK(D) = LQ(D,D) / 2.0_R8 - CENTER_PRIV(1:D-1) = X(1:D-1) - CENTER_PRIV(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) - ! Get the center by applying Q to the solution. - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER_PRIV, D, & - WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - IERR_PRIV = 83; CYCLE - END IF - ! Update the new radius, center, and simplex. - MINRAD_PRIV = DNRM2(D, CENTER_PRIV, 1) - CENTER_PRIV(:) = CENTER_PRIV(:) + PTS(:,SIMPS(1,MI)) - VERTEX_PRIV = I - END DO - !$OMP END DO - !$OMP CRITICAL(REDUC_4) - ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. - IF (VERTEX_PRIV .NE. 0) THEN - IF (DNRM2(D, PTS(:,VERTEX_PRIV) - CENTER(:), 1) < MINRAD) THEN - MINRAD = MINRAD_PRIV - CENTER(:) = CENTER_PRIV(:) - SIMPS(D+1,MI) = VERTEX_PRIV - END IF - END IF - !$OMP END CRITICAL(REDUC_4) - !$OMP END PARALLEL - ! End level 2 parallel region. - - ! Check for error flags. - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = IERR_PRIV - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Check for extrapolation condition. - IF(SIMPS(D+1,MI) .NE. 0) THEN - ! Add new point to the linear system. - AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - END IF -ELSE ! Special case where D=1. - PLANE(1) = 1.0_R8 - PLANE(2) = PTS(1,SIMPS(1,MI)) - SIDE1 = SIGN(1.0_R8, PROJ(1) - PLANE(2)) - ! Initialize the radius, simplex, and OpenMP variabls. - SIMPS(2,MI) = 0 - MINRAD = HUGE(0.0_R8) - MINRAD_PRIV = HUGE(0.0_R8) - VERTEX_PRIV = 0 - ! Begin Level 2 parallel loop over N points in PTS. - !$OMP PARALLEL & - ! - ! The FIRSTPRIVATE list specifies initialized variables, of which each - ! thread has a private copy. - !$OMP& FIRSTPRIVATE(MINRAD_PRIV, VERTEX_PRIV), & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(I, SIDE2), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& IF(PLVL2) - - !$OMP DO SCHEDULE(STATIC) - DO I = 1, N - ! Check that P* is on the appropriate halfspace. - SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 - IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE - ! Check that P* is closer than the current solution. - IF (SIDE2 > MINRAD) CYCLE - ! Update the minimum distance and save the index I. - MINRAD_PRIV = SIDE2 - VERTEX_PRIV = I - END DO - !$OMP END DO - !$OMP CRITICAL(REDUC_4) - ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. - IF (VERTEX_PRIV .NE. 0) THEN - IF (MINRAD_PRIV < MINRAD) THEN - MINRAD = MINRAD_PRIV - SIMPS(2,MI) = VERTEX_PRIV - END IF - END IF - !$OMP END CRITICAL(REDUC_4) - !$OMP END PARALLEL - ! Check for extrapolation condition. - IF(SIMPS(2,MI) .NE. 0) THEN - ! Add new point to the linear system. - AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) - B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 - END IF -END IF -! RETURN -! END SUBROUTINE MAKESIMPLEX -! End of in-lined code for MAKESIMPLEX(). -!****************************************************************************** - - - END DO - ! If the loop terminates, then a good direction was found. - ! Resume the visibility walk as normal. - CYCLE INNER - END IF - - ! Otherwise, project the extrapolation point onto the convex hull. -! CALL PROJECT(); IF (IERR_PRIV .NE. 0) CYCLE OUTER - - -!****************************************************************************** -! Due to OpenMP's handling of variable scope, the parallel (identical to serial) -! implementation of the subroutine PROJECT() has been in-lined here. -! -! SUBROUTINE PROJECT() -! Project a point outside the convex hull of the point set onto the convex hull -! by solving an inequality constrained least squares problem. The solution to -! the least squares problem gives the projection as a convex combination of the -! data points. The projection can then be computed by performing a matrix -! vector multiplication. - -! Allocate work arrays. -IF (.NOT. ALLOCATED(IWORK_DWNNLS)) THEN - ALLOCATE(IWORK_DWNNLS(D+1+N), STAT=IERR_PRIV) - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 70 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF -END IF -IF (.NOT. ALLOCATED(WORK_DWNNLS)) THEN - ALLOCATE(WORK_DWNNLS(D+1+N*5), STAT=IERR_PRIV) - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 70 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF -END IF -IF (.NOT. ALLOCATED(W_DWNNLS)) THEN - ALLOCATE(W_DWNNLS(D+1,N+1), STAT=IERR_PRIV) - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 70 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF -END IF -IF (.NOT. ALLOCATED(X_DWNNLS)) THEN - ALLOCATE(X_DWNNLS(N), STAT=IERR_PRIV) - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 70 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF -END IF - -! Initialize work array and settings values. -IWORK_DWNNLS(1) = D+1+5*N -IWORK_DWNNLS(2) = D+1+N -W_DWNNLS(1, :) = 1.0_R8 ! Set convexity (equality) constraint. -W_DWNNLS(2:D+1,1:N) = PTS(:,:) ! Copy data points. -W_DWNNLS(2:D+1,N+1) = PROJ(:) ! Copy extrapolation point. -! Compute the solution to the inequality constrained least squares problem to -! get the projection coefficients. -CALL DWNNLS(W_DWNNLS, D+1, 1, D, N, 0, PRGOPT_DWNNLS, X_DWNNLS, RNORML, & - IERR_PRIV, IWORK_DWNNLS, WORK_DWNNLS) -IF (IERR_PRIV .EQ. 1) THEN ! Failure to converge. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 71 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER -ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 72 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER -END IF -! Compute the actual projection via matrix vector multiplication. -CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) -! Zero all weights that are approximately zero and renormalize the sum. -WHERE (X_DWNNLS < EPSL) X_DWNNLS = 0.0_R8 -X_DWNNLS(:) = X_DWNNLS(:) / SUM(X_DWNNLS) -! Compute the actual projection via matrix vector multiplication. -CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) -RNORML = DNRM2(D, PROJ(:) - Q(:,MI), 1) -! RETURN -! END SUBROUTINE PROJECT -! End of in-lined code for PROJECT(). -!****************************************************************************** - - - ! Check the value of RNORML for over-extrapolation. - IF (RNORML > EXTRAPL * PTS_DIAM) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! If present, record the unscaled RNORM output. - IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE - ! Set the error flag and skip this point. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 2 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - - ! Otherwise, restore the previous simplex and continue with the - ! projected value. - SIMPS(D+1,MI) = ITMP - AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - IEXTRAPS = IEXTRAPS - 1 ! Decrement the budget. - END IF - - ! End of inner loop for finding each interpolation point. - END DO INNER - - ! Check for budget violation conditions. - IF (K > IBUDGETL) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! Set the error flag and skip this point. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 60 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - - ! If the residual is nonzero, set the extrapolation flag. - IF (RNORML > EPSL) THEN - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 1 - !$OMP END CRITICAL(CHECK_IERR) - END IF - - ! If present, record the RNORM output. - IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE - -END DO OUTER ! End of outer loop over all interpolation points. -!$OMP END DO - -! If INTERP_IN and INTERP_OUT are present, compute all values f(q). -IF (PRESENT(INTERP_IN)) THEN - ! Level 1 parallel loop over all interpolation points. - !$OMP DO SCHEDULE(STATIC) - DO MI = 1, M - ! Check for errors. - IF (IERR(MI) .LE. 1) THEN - ! Compute the weighted sum of vertex response values. - DO K = 1, D+1 - INTERP_OUT(:,MI) = INTERP_OUT(:,MI) & - + INTERP_IN(:,SIMPS(K,MI)) * WEIGHTS(K,MI) - END DO - END IF - END DO - !$OMP END DO -END IF - -! Free optional work arrays. -IF (ALLOCATED(IWORK_DWNNLS)) DEALLOCATE(IWORK_DWNNLS) -IF (ALLOCATED(WORK_DWNNLS)) DEALLOCATE(WORK_DWNNLS) -IF (ALLOCATED(W_DWNNLS)) DEALLOCATE(W_DWNNLS) -IF (ALLOCATED(X_DWNNLS)) DEALLOCATE(X_DWNNLS) -!$OMP END PARALLEL -! End of Level 1 parallel region. - -! Free dynamic work arrays. -DEALLOCATE(WORK) - -RETURN - -CONTAINS ! Internal subroutines and functions. - -SUBROUTINE RESCALE(MINDIST, DIAMETER, SCALE) -! Rescale and transform data to be centered at the origin with unit -! radius. -! -! The parallel implementation of this subroutine exploits parallelism -! over loops of length N. For nested loops, this subroutine follows -! the OpenMP recommendation of a static schedule with a fixed chunk -! size (of 100). -! -! On output, PTS and Q have been rescaled and shifted. All the data -! points in PTS are centered with unit radius, and the points in Q -! have been shifted and scaled in relation to PTS. -! -! MINDIST is a real number containing the (scaled) minimum distance -! between any two data points in PTS. -! -! DIAMETER is a real number containing the (scaled) diameter of the -! data set PTS. -! -! SCALE contains the real factor used to transform the data and -! interpolation points: scaled value = (original value - -! barycenter of data points)/SCALE. - -! Output arguments. -REAL(KIND=R8), INTENT(OUT) :: MINDIST, DIAMETER, SCALE - -! Local variables. -REAL(KIND=R8) :: PTS_CENTER(D) ! The center of the data points PTS. -REAL(KIND=R8) :: DISTANCE ! The current distance. - -! Initialize local values. -MINDIST = HUGE(0.0_R8) -DIAMETER = 0.0_R8 -SCALE = 0.0_R8 - -! Compute barycenter of all data points. -PTS_CENTER(:) = SUM(PTS(:,:), DIM=2)/REAL(N, KIND=R8) -! Center the points. -FORALL (I = 1:N) PTS(:,I) = PTS(:,I) - PTS_CENTER(:) -! Compute the scale factor (for unit radius). -!$OMP PARALLEL DO & -!$OMP& PRIVATE(I, DISTANCE), & -!$OMP& REDUCTION(MAX:SCALE), & -!$OMP& SCHEDULE(STATIC), & -!$OMP& DEFAULT(SHARED) -DO I = 1, N ! Cycle through all points again. - DISTANCE = DNRM2(D, PTS(:,I), 1) ! Compute the distance from the center. - IF (DISTANCE > SCALE) THEN ! Compare to the current radius. - SCALE = DISTANCE - END IF -END DO -!$OMP END PARALLEL DO -! Scale the points to unit radius. -PTS = PTS / SCALE -! Also transform Q similarly. -FORALL (I = 1:M) Q(:,I) = (Q(:,I) - PTS_CENTER(:)) / SCALE -! Compute the minimum and maximum distances. -IF (EXACTL) THEN - ! If exact error error checking is turned on, then compute the DIAMETER - ! and MINDIST values. - !$OMP PARALLEL DO & - !$OMP& PRIVATE(I, DISTANCE), & - !$OMP& REDUCTION(MAX:DIAMETER), & - !$OMP& REDUCTION(MIN:MINDIST), & - !$OMP& SCHEDULE(STATIC, 100), & - !$OMP& DEFAULT(SHARED) - DO I = 1, N ! Cycle through all pairs of points. - DO J = I + 1, N - DISTANCE = DNRM2(D, PTS(:,I) - PTS(:,J), 1) ! Compute the distance. - IF (DISTANCE > DIAMETER) THEN ! Compare to the current diameter. - DIAMETER = DISTANCE - END IF - IF (DISTANCE < MINDIST) THEN ! Compare to the current minimum distance. - MINDIST = DISTANCE - END IF - END DO - END DO - !$OMP END PARALLEL DO -ELSE - ! If exact error checking is turned off, then the diameter is approximately - ! 2.0 after rescaling and centering the points. The MINDIST is not computed. - DIAMETER = 2.0_R8 - MINDIST = 1.0_R8 -END IF -RETURN -END SUBROUTINE RESCALE - -END SUBROUTINE DELAUNAYSPARSEP diff --git a/extras/c_binding/delsparse.h b/extras/c_binding/delsparse.h deleted file mode 100644 index 4ed0241..0000000 --- a/extras/c_binding/delsparse.h +++ /dev/null @@ -1,59 +0,0 @@ -#ifndef DELSPARSEC -#define DELSPARSEC - -// serial subroutine: no optional arguments -extern void c_delaunaysparses(int *d, int *n, double pts[], int *m, double q[], - int simps[], double weights[], int ierr[]); - -// serial: compute interpolant values -extern void c_delaunaysparses_interp(int *d, int *n, double pts[], int *m, - double q[], int simps[], double weights[], - int ierr[], int *ir, double interp_in[], - double interp_out[]); - -// serial: optional arguments, no interpolant values -extern void c_delaunaysparses_opts(int *d, int *n, double pts[], int *m, - double q[],int simps[], double weights[], - int ierr[], double *eps, double *extrap, - double rnorm[], int *ibudget, bool *chain, - bool *exact); - -// serial: optional arguments and compute interpolant values -extern void c_delaunaysparses_interp_opts(int *d, int *n, double pts[], int *m, - double q[],int simps[], - double weights[], int ierr[], - int *ir, double interp_in[], - double interp_out[], double *eps, - double *extrap, double rnorm[], - int *ibudget, bool *chain, - bool *exact); - - -// parallel: no optional arguments -extern void c_delaunaysparsep(int *d, int *n, double pts[], int *m, double q[], - int simps[], double weights[], int ierr[]); - -// parallel: compute interpolant values -extern void c_delaunaysparsep_interp(int *d, int *n, double pts[], int *m, - double q[], int simps[], double weights[], - int ierr[], int *ir, double interp_in[], - double interp_out[]); - -// parallel: optional arguments, no interpolant values -extern void c_delaunaysparsep_opts(int *d, int *n, double pts[], int *m, - double q[],int simps[], double weights[], - int ierr[], double *eps, double *extrap, - double rnorm[], int *ibudget, bool *chain, - bool *exact, int *pmode); - -// parallel: optional arguments and compute interpolant values -extern void c_delaunaysparsep_interp_opts(int *d, int *n, double pts[], int *m, - double q[],int simps[], - double weights[], int ierr[], - int *ir, double interp_in[], - double interp_out[], double *eps, - double *extrap, double rnorm[], - int *ibudget, bool *chain, - bool *exact, int *pmode); - -#endif diff --git a/extras/c_binding/delsparse_bind_c.f90 b/extras/c_binding/delsparse_bind_c.f90 deleted file mode 100644 index a1e5c78..0000000 --- a/extras/c_binding/delsparse_bind_c.f90 +++ /dev/null @@ -1,1265 +0,0 @@ - - -SUBROUTINE C_DELAUNAYSPARSES_NOOPTS(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR) & - BIND(C, NAME="c_delaunaysparses") - ! This is a wrapper for DELAUNAYSPARSES with no optional arguments. - ! - ! - ! On input: - ! - ! D is the dimension of the space for PTS and Q. - ! - ! N is the number of data points in PTS. - ! - ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the - ! coordinates of a single data point in R^D. - ! - ! M is the number of interpolation points in Q. - ! - ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the - ! coordinates of a single interpolation point in R^D. - ! - ! - ! On output: - ! - ! PTS and Q have been rescaled and shifted. All the data points in PTS - ! are now contained in the unit hyperball in R^D, and the points in Q - ! have been shifted and scaled accordingly in relation to PTS. - ! - ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns - ! in PTS) for the D+1 vertices of the Delaunay simplex containing each - ! interpolation point in Q. - ! - ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each - ! point in Q as a convex combination of the D+1 corresponding vertices - ! in SIMPS. - ! - ! IERR(1:M) contains integer valued error flags associated with the - ! computation of each of the M interpolation points in Q. The error - ! codes are given in the definition of DELAUNAYSPARSES in delsparse.f90. - ! - ! - ! LAST UPDATE: - ! 11/2020 by THC - ! - USE REAL_PRECISION , ONLY : R8 - USE ISO_C_BINDING - - IMPLICIT NONE - - INTEGER(C_INT), INTENT(IN) :: D - INTEGER(C_INT), INTENT(IN) :: N - REAL(C_DOUBLE), INTENT(INOUT) :: PTS(D,N) - INTEGER(C_INT), INTENT(IN) :: M - REAL(C_DOUBLE), INTENT(INOUT) :: Q(D,M) - INTEGER(C_INT), INTENT(OUT) :: SIMPS(D+1,M) - REAL(C_DOUBLE), INTENT(OUT) :: WEIGHTS(D+1,M) - INTEGER(C_INT), INTENT(OUT) :: IERR(M) - - INTERFACE - SUBROUTINE DELAUNAYSPARSES(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, & - RNORM, IBUDGET, CHAIN, EXACT) - USE REAL_PRECISION , ONLY : R8 - IMPLICIT NONE - INTEGER, INTENT(IN) :: D - INTEGER, INTENT(IN) :: N - REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) - INTEGER, INTENT(IN) :: M - REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) - INTEGER, INTENT(OUT) :: SIMPS(:,:) - REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) - INTEGER, INTENT(OUT) :: IERR(:) - REAL(KIND=R8), INTENT(IN), OPTIONAL :: INTERP_IN(:,:) - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) - INTEGER, INTENT(IN), OPTIONAL :: IBUDGET - LOGICAL, INTENT(IN), OPTIONAL :: CHAIN - LOGICAL, INTENT(IN), OPTIONAL :: EXACT - END SUBROUTINE DELAUNAYSPARSES - END INTERFACE - - INTEGER :: D_LOC - INTEGER :: N_LOC - REAL(KIND=R8) :: PTS_LOC(D, N) - INTEGER :: M_LOC - REAL(KIND=R8) :: Q_LOC(D, M) - INTEGER :: SIMPS_LOC(D+1, M) - REAL(KIND=R8) :: WEIGHTS_LOC(D+1, M) - INTEGER :: IERR_LOC(M) - - D_LOC = INT(D) - N_LOC = INT(N) - PTS_LOC = REAL(PTS, KIND=R8) - M_LOC = INT(M) - Q_LOC = REAL(Q, KIND=R8) - - CALL DELAUNAYSPARSES(D_LOC, N_LOC, PTS_LOC, M_LOC, Q_LOC, SIMPS_LOC, & - WEIGHTS_LOC, IERR_LOC) - - PTS = REAL(PTS_LOC, KIND=C_DOUBLE) - Q = REAL(Q_LOC, KIND=C_DOUBLE) - SIMPS = INT(SIMPS_LOC, KIND=C_INT) - WEIGHTS = REAL(WEIGHTS_LOC, KIND=C_DOUBLE) - IERR = INT(IERR_LOC, KIND=C_INT) - - RETURN -END SUBROUTINE C_DELAUNAYSPARSES_NOOPTS - - -SUBROUTINE C_DELAUNAYSPARSES_INTERP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - IR, INTERP_IN, INTERP_OUT) & - BIND(C, NAME="c_delaunaysparses_interp") - ! This is a wrapper for DELAUNAYSPARSES with INTERP_IN and INTERP_OUT - ! specified, but no other optional arguments. Unlike the Fortran interface, - ! in this interface the dimension of the response variables (IR) must - ! be explicitly specified by an additional input, IR. - ! - ! - ! On input: - ! - ! D is the dimension of the space for PTS and Q. - ! - ! N is the number of data points in PTS. - ! - ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the - ! coordinates of a single data point in R^D. - ! - ! M is the number of interpolation points in Q. - ! - ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the - ! coordinates of a single interpolation point in R^D. - ! - ! IR is the dimension of the response variables. - ! - ! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of - ! the data points in PTS on input. The first dimension of INTERP_IN is - ! inferred to be the dimension of these response vectors, and the - ! second dimension must match N. - ! - ! - ! On output: - ! - ! PTS and Q have been rescaled and shifted. All the data points in PTS - ! are now contained in the unit hyperball in R^D, and the points in Q - ! have been shifted and scaled accordingly in relation to PTS. - ! - ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns - ! in PTS) for the D+1 vertices of the Delaunay simplex containing each - ! interpolation point in Q. - ! - ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each - ! point in Q as a convex combination of the D+1 corresponding vertices - ! in SIMPS. - ! - ! IERR(1:M) contains integer valued error flags associated with the - ! computation of each of the M interpolation points in Q. The error - ! codes are given in the definition of DELAUNAYSPARSES in delsparse.f90. - ! - ! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each - ! interpolation point in Q on output. The first dimension of INTERP_OU - ! must match the first dimension of INTERP_IN, and the second dimension - ! must match M. - ! - ! - ! LAST UPDATE: - ! 11/2020 by THC - ! - USE REAL_PRECISION , ONLY : R8 - USE ISO_C_BINDING - - IMPLICIT NONE - - INTEGER(C_INT), INTENT(IN) :: D - INTEGER(C_INT), INTENT(IN) :: N - REAL(C_DOUBLE), INTENT(INOUT) :: PTS(D,N) - INTEGER(C_INT), INTENT(IN) :: M - REAL(C_DOUBLE), INTENT(INOUT) :: Q(D,M) - INTEGER(C_INT), INTENT(OUT) :: SIMPS(D+1,M) - REAL(C_DOUBLE), INTENT(OUT) :: WEIGHTS(D+1,M) - INTEGER(C_INT), INTENT(OUT) :: IERR(M) - INTEGER(C_INT), INTENT(IN) :: IR - REAL(C_DOUBLE), INTENT(IN) :: INTERP_IN(IR, N) - REAL(C_DOUBLE), INTENT(OUT) :: INTERP_OUT(IR, M) - - INTERFACE - SUBROUTINE DELAUNAYSPARSES(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, & - RNORM, IBUDGET, CHAIN, EXACT) - USE REAL_PRECISION , ONLY : R8 - IMPLICIT NONE - INTEGER, INTENT(IN) :: D - INTEGER, INTENT(IN) :: N - REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) - INTEGER, INTENT(IN) :: M - REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) - INTEGER, INTENT(OUT) :: SIMPS(:,:) - REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) - INTEGER, INTENT(OUT) :: IERR(:) - REAL(KIND=R8), INTENT(IN), OPTIONAL :: INTERP_IN(:,:) - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) - INTEGER, INTENT(IN), OPTIONAL :: IBUDGET - LOGICAL, INTENT(IN), OPTIONAL :: CHAIN - LOGICAL, INTENT(IN), OPTIONAL :: EXACT - END SUBROUTINE DELAUNAYSPARSES - END INTERFACE - - INTEGER :: D_LOC - INTEGER :: N_LOC - REAL(KIND=R8) :: PTS_LOC(D, N) - INTEGER :: M_LOC - REAL(KIND=R8) :: Q_LOC(D, M) - INTEGER :: SIMPS_LOC(D+1, M) - REAL(KIND=R8) :: WEIGHTS_LOC(D+1, M) - INTEGER :: IERR_LOC(M) - REAL(KIND=R8) :: INTERP_IN_LOC(IR, N) - REAL(KIND=R8) :: INTERP_OUT_LOC(IR, M) - - D_LOC = INT(D) - N_LOC = INT(N) - PTS_LOC = REAL(PTS, KIND=R8) - M_LOC = INT(M) - Q_LOC = REAL(Q, KIND=R8) - INTERP_IN_LOC = REAL(INTERP_IN, KIND=R8) - - CALL DELAUNAYSPARSES(D_LOC, N_LOC, PTS_LOC, M_LOC, Q_LOC, SIMPS_LOC, & - WEIGHTS_LOC, IERR_LOC, INTERP_IN=INTERP_IN_LOC, & - INTERP_OUT=INTERP_OUT_LOC) - - PTS = REAL(PTS_LOC, KIND=C_DOUBLE) - Q = REAL(Q_LOC, KIND=C_DOUBLE) - SIMPS = INT(SIMPS_LOC, KIND=C_INT) - WEIGHTS = REAL(WEIGHTS_LOC, KIND=C_DOUBLE) - IERR = INT(IERR_LOC, KIND=C_INT) - INTERP_OUT = REAL(INTERP_OUT_LOC, KIND=C_DOUBLE) - - RETURN -END SUBROUTINE C_DELAUNAYSPARSES_INTERP - - -SUBROUTINE C_DELAUNAYSPARSES_OPTS(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, EPS, & - EXTRAP, RNORM, IBUDGET, CHAIN, EXACT) & - BIND(C, NAME="c_delaunaysparses_opts") - ! This is a wrapper for DELAUNAYSPARSES without INTERP_IN and INTERP_OUT, - ! but all other optional arguments present. - ! - ! - ! On input: - ! - ! D is the dimension of the space for PTS and Q. - ! - ! N is the number of data points in PTS. - ! - ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the - ! coordinates of a single data point in R^D. - ! - ! M is the number of interpolation points in Q. - ! - ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the - ! coordinates of a single interpolation point in R^D. - ! - ! EXTRAP contains the real maximum extrapolation distance (relative to the - ! diameter of PTS) on input. Interpolation at a point outside the convex - ! hull of PTS is done by projecting that point onto the convex hull, and - ! then doing normal Delaunay interpolation at that projection. - ! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) - ! units outside the convex hull of PTS will not be done and an error code - ! of 2 will be returned. Note that computing the projection can be - ! expensive. Setting EXTRAP=0 will cause all extrapolation points to be - ! ignored without ever computing a projection. - ! - ! IBUDGET on input contains the integer budget for performing flips while - ! iterating toward the simplex containing each interpolation point in Q. - ! This prevents DELAUNAYSPARSES from falling into an infinite loop when - ! an inappropriate value of EPS is given with respect to the problem - ! conditioning. For most cases, the default value of 50000 should be - ! more than sufficient. - ! - ! CHAIN is a logical input argument that determines whether a new first - ! simplex should be constructed for each interpolation point - ! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." - ! Setting CHAIN=.TRUE. is generally not recommended, unless the size of - ! the triangulation is relatively small or the interpolation points are - ! known to be tightly clustered. - ! - ! EXACT is a logical input argument that determines whether the exact - ! diameter should be computed and whether a check for duplicate data - ! points should be performed in advance. When EXACT=.FALSE., the - ! diameter of PTS is approximated by twice the distance from the - ! barycenter of PTS to the farthest point in PTS, and no check is - ! done to find the closest pair of points, which could result in hard - ! to find bugs later on. When EXACT=.TRUE., the exact diameter is - ! computed and an error is returned whenever PTS contains duplicate - ! values up to the precision EPS. Setting EXACT=.FALSE. could result - ! in significant speedup when N is large, but it is strongly - ! recommended that most users leave EXACT=.TRUE., as setting - ! EXACT=.FALSE. could result in input errors that are difficult - ! to identify. Also, the diameter approximation could be wrong by up - ! to a factor of two. - ! - ! - ! On output: - ! - ! PTS and Q have been rescaled and shifted. All the data points in PTS - ! are now contained in the unit hyperball in R^D, and the points in Q - ! have been shifted and scaled accordingly in relation to PTS. - ! - ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns - ! in PTS) for the D+1 vertices of the Delaunay simplex containing each - ! interpolation point in Q. - ! - ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each - ! point in Q as a convex combination of the D+1 corresponding vertices - ! in SIMPS. - ! - ! IERR(1:M) contains integer valued error flags associated with the - ! computation of each of the M interpolation points in Q. The error - ! codes are given in the definition of DELAUNAYSPARSES in delsparse.f90. - ! - ! RNORM(1:M) contains the real unscaled projection (2-norm) distances from - ! any projection computations on output. - ! - ! - ! LAST UPDATE: - ! 11/2020 by THC - ! - USE REAL_PRECISION , ONLY : R8 - USE ISO_C_BINDING - - IMPLICIT NONE - - INTEGER(C_INT), INTENT(IN) :: D - INTEGER(C_INT), INTENT(IN) :: N - REAL(C_DOUBLE), INTENT(INOUT) :: PTS(D,N) - INTEGER(C_INT), INTENT(IN) :: M - REAL(C_DOUBLE), INTENT(INOUT) :: Q(D,M) - INTEGER(C_INT), INTENT(OUT) :: SIMPS(D+1,M) - REAL(C_DOUBLE), INTENT(OUT) :: WEIGHTS(D+1,M) - INTEGER(C_INT), INTENT(OUT) :: IERR(M) - REAL(C_DOUBLE), INTENT(IN) :: EPS - REAL(C_DOUBLE), INTENT(IN) :: EXTRAP - REAL(C_DOUBLE), INTENT(OUT) :: RNORM(M) - INTEGER(C_INT), INTENT(IN) :: IBUDGET - LOGICAL(C_BOOL), INTENT(IN) :: CHAIN - LOGICAL(C_BOOL), INTENT(IN) :: EXACT - - INTERFACE - SUBROUTINE DELAUNAYSPARSES(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, & - RNORM, IBUDGET, CHAIN, EXACT) - USE REAL_PRECISION , ONLY : R8 - IMPLICIT NONE - INTEGER, INTENT(IN) :: D - INTEGER, INTENT(IN) :: N - REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) - INTEGER, INTENT(IN) :: M - REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) - INTEGER, INTENT(OUT) :: SIMPS(:,:) - REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) - INTEGER, INTENT(OUT) :: IERR(:) - REAL(KIND=R8), INTENT(IN), OPTIONAL :: INTERP_IN(:,:) - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) - INTEGER, INTENT(IN), OPTIONAL :: IBUDGET - LOGICAL, INTENT(IN), OPTIONAL :: CHAIN - LOGICAL, INTENT(IN), OPTIONAL :: EXACT - END SUBROUTINE DELAUNAYSPARSES - END INTERFACE - - INTEGER :: D_LOC - INTEGER :: N_LOC - REAL(KIND=R8) :: PTS_LOC(D, N) - INTEGER :: M_LOC - REAL(KIND=R8) :: Q_LOC(D, M) - INTEGER :: SIMPS_LOC(D+1, M) - REAL(KIND=R8) :: WEIGHTS_LOC(D+1, M) - INTEGER :: IERR_LOC(M) - REAL(KIND=R8) :: EPS_LOC - REAL(KIND=R8) :: EXTRAP_LOC - REAL(KIND=R8) :: RNORM_LOC(M) - INTEGER :: IBUDGET_LOC - LOGICAL :: CHAIN_LOC - LOGICAL :: EXACT_LOC - - D_LOC = INT(D) - N_LOC = INT(N) - PTS_LOC = REAL(PTS, KIND=R8) - M_LOC = INT(M) - Q_LOC = REAL(Q, KIND=R8) - EPS_LOC = REAL(EPS, KIND=R8) - EXTRAP_LOC = REAL(EXTRAP, KIND=R8) - IBUDGET_LOC = INT(IBUDGET) - CHAIN_LOC = LOGICAL(CHAIN) - EXACT_LOC = LOGICAL(EXACT) - - CALL DELAUNAYSPARSES(D_LOC, N_LOC, PTS_LOC, M_LOC, Q_LOC, SIMPS_LOC, & - WEIGHTS_LOC, IERR_LOC, EPS=EPS_LOC, & - EXTRAP=EXTRAP_LOC, RNORM=RNORM_LOC, & - IBUDGET=IBUDGET_LOC, CHAIN=CHAIN_LOC, & - EXACT=EXACT_LOC) - - PTS = REAL(PTS_LOC, KIND=C_DOUBLE) - Q = REAL(Q_LOC, KIND=C_DOUBLE) - SIMPS = INT(SIMPS_LOC, KIND=C_INT) - WEIGHTS = REAL(WEIGHTS_LOC, KIND=C_DOUBLE) - IERR = INT(IERR_LOC, KIND=C_INT) - RNORM = REAL(RNORM_LOC, KIND=C_DOUBLE) - - RETURN -END SUBROUTINE C_DELAUNAYSPARSES_OPTS - - -SUBROUTINE C_DELAUNAYSPARSES_INTERP_OPTS(D, N, PTS, M, Q, SIMPS, WEIGHTS, & - IERR, IR, INTERP_IN, INTERP_OUT, & - EPS, EXTRAP, RNORM, IBUDGET, CHAIN, & - EXACT, PMODE) & - BIND(C, NAME="c_delaunaysparses_interp_opts") - ! This is a wrapper for DELAUNAYSPARSES with all optional arguments present. - ! - ! - ! On input: - ! - ! D is the dimension of the space for PTS and Q. - ! - ! N is the number of data points in PTS. - ! - ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the - ! coordinates of a single data point in R^D. - ! - ! M is the number of interpolation points in Q. - ! - ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the - ! coordinates of a single interpolation point in R^D. - ! - ! IR is the dimension of the response variables. - ! - ! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of - ! the data points in PTS on input. The first dimension of INTERP_IN is - ! inferred to be the dimension of these response vectors, and the - ! second dimension must match N. - ! - ! EXTRAP contains the real maximum extrapolation distance (relative to the - ! diameter of PTS) on input. Interpolation at a point outside the convex - ! hull of PTS is done by projecting that point onto the convex hull, and - ! then doing normal Delaunay interpolation at that projection. - ! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) - ! units outside the convex hull of PTS will not be done and an error code - ! of 2 will be returned. Note that computing the projection can be - ! expensive. Setting EXTRAP=0 will cause all extrapolation points to be - ! ignored without ever computing a projection. - ! - ! IBUDGET on input contains the integer budget for performing flips while - ! iterating toward the simplex containing each interpolation point in Q. - ! This prevents DELAUNAYSPARSES from falling into an infinite loop when - ! an inappropriate value of EPS is given with respect to the problem - ! conditioning. For most cases, the default value of 50000 should be - ! more than sufficient. - ! - ! CHAIN is a logical input argument that determines whether a new first - ! simplex should be constructed for each interpolation point - ! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." - ! Setting CHAIN=.TRUE. is generally not recommended, unless the size of - ! the triangulation is relatively small or the interpolation points are - ! known to be tightly clustered. - ! - ! EXACT is a logical input argument that determines whether the exact - ! diameter should be computed and whether a check for duplicate data - ! points should be performed in advance. When EXACT=.FALSE., the - ! diameter of PTS is approximated by twice the distance from the - ! barycenter of PTS to the farthest point in PTS, and no check is - ! done to find the closest pair of points, which could result in hard - ! to find bugs later on. When EXACT=.TRUE., the exact diameter is - ! computed and an error is returned whenever PTS contains duplicate - ! values up to the precision EPS. Setting EXACT=.FALSE. could result - ! in significant speedup when N is large, but it is strongly - ! recommended that most users leave EXACT=.TRUE., as setting - ! EXACT=.FALSE. could result in input errors that are difficult - ! to identify. Also, the diameter approximation could be wrong by up - ! to a factor of two. - ! - ! PMODE is an integer specifying the level of parallelism to be exploited. - ! If PMODE = 1, then parallelism is exploited at the level of the loop - ! over all interpolation points (Level 1 parallelism). - ! If PMODE = 2, then parallelism is exploited at the level of the loops - ! over data points when constructing/flipping simplices (Level 2 - ! parallelism). - ! If PMODE = 3, then parallelism is exploited at both levels. Note: this - ! implies that the total number of threads active at any time could be up - ! to OMP_NUM_THREADS^2. - ! - ! - ! On output: - ! - ! PTS and Q have been rescaled and shifted. All the data points in PTS - ! are now contained in the unit hyperball in R^D, and the points in Q - ! have been shifted and scaled accordingly in relation to PTS. - ! - ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns - ! in PTS) for the D+1 vertices of the Delaunay simplex containing each - ! interpolation point in Q. - ! - ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each - ! point in Q as a convex combination of the D+1 corresponding vertices - ! in SIMPS. - ! - ! IERR(1:M) contains integer valued error flags associated with the - ! computation of each of the M interpolation points in Q. The error - ! codes are given in the definition of DELAUNAYSPARSES in delsparse.f90. - ! - ! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each - ! interpolation point in Q on output. The first dimension of INTERP_OUT - ! must match the first dimension of INTERP_IN, and the second dimension - ! must match M. - ! - ! RNORM(1:M) contains the real unscaled projection (2-norm) distances from - ! any projection computations on output. - ! - ! - ! LAST UPDATE: - ! 11/2020 by THC - ! - USE REAL_PRECISION , ONLY : R8 - USE ISO_C_BINDING - - IMPLICIT NONE - - INTEGER(C_INT), INTENT(IN) :: D - INTEGER(C_INT), INTENT(IN) :: N - REAL(C_DOUBLE), INTENT(INOUT) :: PTS(D,N) - INTEGER(C_INT), INTENT(IN) :: M - REAL(C_DOUBLE), INTENT(INOUT) :: Q(D,M) - INTEGER(C_INT), INTENT(OUT) :: SIMPS(D+1,M) - REAL(C_DOUBLE), INTENT(OUT) :: WEIGHTS(D+1,M) - INTEGER(C_INT), INTENT(OUT) :: IERR(M) - INTEGER(C_INT), INTENT(IN) :: IR - REAL(C_DOUBLE), INTENT(IN) :: INTERP_IN(IR, N) - REAL(C_DOUBLE), INTENT(OUT) :: INTERP_OUT(IR, M) - REAL(C_DOUBLE), INTENT(IN) :: EPS - REAL(C_DOUBLE), INTENT(IN) :: EXTRAP - REAL(C_DOUBLE), INTENT(OUT) :: RNORM(M) - INTEGER(C_INT), INTENT(IN) :: IBUDGET - LOGICAL(C_BOOL), INTENT(IN) :: CHAIN - LOGICAL(C_BOOL), INTENT(IN) :: EXACT - INTEGER(C_INT), INTENT(IN) :: PMODE - - INTERFACE - SUBROUTINE DELAUNAYSPARSES(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, & - RNORM, IBUDGET, CHAIN, EXACT) - USE REAL_PRECISION , ONLY : R8 - IMPLICIT NONE - INTEGER, INTENT(IN) :: D - INTEGER, INTENT(IN) :: N - REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) - INTEGER, INTENT(IN) :: M - REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) - INTEGER, INTENT(OUT) :: SIMPS(:,:) - REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) - INTEGER, INTENT(OUT) :: IERR(:) - REAL(KIND=R8), INTENT(IN), OPTIONAL :: INTERP_IN(:,:) - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) - INTEGER, INTENT(IN), OPTIONAL :: IBUDGET - LOGICAL, INTENT(IN), OPTIONAL :: CHAIN - LOGICAL, INTENT(IN), OPTIONAL :: EXACT - END SUBROUTINE DELAUNAYSPARSES - END INTERFACE - - INTEGER :: D_LOC - INTEGER :: N_LOC - REAL(KIND=R8) :: PTS_LOC(D, N) - INTEGER :: M_LOC - REAL(KIND=R8) :: Q_LOC(D, M) - INTEGER :: SIMPS_LOC(D+1, M) - REAL(KIND=R8) :: WEIGHTS_LOC(D+1, M) - INTEGER :: IERR_LOC(M) - REAL(KIND=R8) :: INTERP_IN_LOC(IR, N) - REAL(KIND=R8) :: INTERP_OUT_LOC(IR, M) - REAL(KIND=R8) :: EPS_LOC - REAL(KIND=R8) :: EXTRAP_LOC - REAL(KIND=R8) :: RNORM_LOC(M) - INTEGER :: IBUDGET_LOC - LOGICAL :: CHAIN_LOC - LOGICAL :: EXACT_LOC - INTEGER :: PMODE_LOC - - D_LOC = INT(D) - N_LOC = INT(N) - PTS_LOC = REAL(PTS, KIND=R8) - M_LOC = INT(M) - Q_LOC = REAL(Q, KIND=R8) - INTERP_IN_LOC = REAL(INTERP_IN, KIND=R8) - EPS_LOC = REAL(EPS, KIND=R8) - EXTRAP_LOC = REAL(EXTRAP, KIND=R8) - IBUDGET_LOC = INT(IBUDGET) - CHAIN_LOC = LOGICAL(CHAIN) - EXACT_LOC = LOGICAL(EXACT) - PMODE_LOC = INT(PMODE) - - CALL DELAUNAYSPARSES(D_LOC, N_LOC, PTS_LOC, M_LOC, Q_LOC, SIMPS_LOC, & - WEIGHTS_LOC, IERR_LOC, INTERP_IN=INTERP_IN_LOC, & - INTERP_OUT=INTERP_OUT_LOC, EPS=EPS_LOC, & - EXTRAP=EXTRAP_LOC, RNORM=RNORM_LOC, & - IBUDGET=IBUDGET_LOC, CHAIN=CHAIN_LOC, & - EXACT=EXACT_LOC) - - PTS = REAL(PTS_LOC, KIND=C_DOUBLE) - Q = REAL(Q_LOC, KIND=C_DOUBLE) - SIMPS = INT(SIMPS_LOC, KIND=C_INT) - WEIGHTS = REAL(WEIGHTS_LOC, KIND=C_DOUBLE) - IERR = INT(IERR_LOC, KIND=C_INT) - INTERP_OUT = REAL(INTERP_OUT_LOC, C_DOUBLE) - RNORM = REAL(RNORM_LOC, KIND=C_DOUBLE) - - RETURN -END SUBROUTINE C_DELAUNAYSPARSES_INTERP_OPTS - - -SUBROUTINE C_DELAUNAYSPARSEP_NOOPTS(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR) & - BIND(C, NAME="c_delaunaysparsep") - ! This is a wrapper for DELAUNAYSPARSEP with no optional arguments. - ! - ! - ! On input: - ! - ! D is the dimension of the space for PTS and Q. - ! - ! N is the number of data points in PTS. - ! - ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the - ! coordinates of a single data point in R^D. - ! - ! M is the number of interpolation points in Q. - ! - ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the - ! coordinates of a single interpolation point in R^D. - ! - ! - ! On output: - ! - ! PTS and Q have been rescaled and shifted. All the data points in PTS - ! are now contained in the unit hyperball in R^D, and the points in Q - ! have been shifted and scaled accordingly in relation to PTS. - ! - ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns - ! in PTS) for the D+1 vertices of the Delaunay simplex containing each - ! interpolation point in Q. - ! - ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each - ! point in Q as a convex combination of the D+1 corresponding vertices - ! in SIMPS. - ! - ! IERR(1:M) contains integer valued error flags associated with the - ! computation of each of the M interpolation points in Q. The error - ! codes are given in the definition of DELAUNAYSPARSEP in delsparse.f90. - ! - ! - ! LAST UPDATE: - ! 11/2020 by THC - ! - USE REAL_PRECISION , ONLY : R8 - USE ISO_C_BINDING - IMPLICIT NONE - - INTEGER(C_INT), INTENT(IN) :: D - INTEGER(C_INT), INTENT(IN) :: N - REAL(C_DOUBLE), INTENT(INOUT) :: PTS(D,N) - INTEGER(C_INT), INTENT(IN) :: M - REAL(C_DOUBLE), INTENT(INOUT) :: Q(D,M) - INTEGER(C_INT), INTENT(OUT) :: SIMPS(D+1,M) - REAL(C_DOUBLE), INTENT(OUT) :: WEIGHTS(D+1,M) - INTEGER(C_INT), INTENT(OUT) :: IERR(M) - - INTERFACE - SUBROUTINE DELAUNAYSPARSEP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, & - RNORM, IBUDGET, CHAIN, EXACT, PMODE) - USE REAL_PRECISION , ONLY : R8 - IMPLICIT NONE - INTEGER, INTENT(IN) :: D - INTEGER, INTENT(IN) :: N - REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) - INTEGER, INTENT(IN) :: M - REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) - INTEGER, INTENT(OUT) :: SIMPS(:,:) - REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) - INTEGER, INTENT(OUT) :: IERR(:) - REAL(KIND=R8), INTENT(IN), OPTIONAL :: INTERP_IN(:,:) - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) - INTEGER, INTENT(IN), OPTIONAL :: IBUDGET - LOGICAL, INTENT(IN), OPTIONAL :: CHAIN - LOGICAL, INTENT(IN), OPTIONAL :: EXACT - INTEGER, INTENT(IN), OPTIONAL :: PMODE - END SUBROUTINE DELAUNAYSPARSEP - END INTERFACE - - INTEGER :: D_LOC - INTEGER :: N_LOC - REAL(KIND=R8) :: PTS_LOC(D, N) - INTEGER :: M_LOC - REAL(KIND=R8) :: Q_LOC(D, M) - INTEGER :: SIMPS_LOC(D+1, M) - REAL(KIND=R8) :: WEIGHTS_LOC(D+1, M) - INTEGER :: IERR_LOC(M) - - D_LOC = INT(D) - N_LOC = INT(N) - PTS_LOC = REAL(PTS, KIND=R8) - M_LOC = INT(M) - Q_LOC = REAL(Q, KIND=R8) - - CALL DELAUNAYSPARSEP(D_LOC, N_LOC, PTS_LOC, M_LOC, Q_LOC, SIMPS_LOC, & - WEIGHTS_LOC, IERR_LOC) - - PTS = REAL(PTS_LOC, KIND=C_DOUBLE) - Q = REAL(Q_LOC, KIND=C_DOUBLE) - SIMPS = INT(SIMPS_LOC, KIND=C_INT) - WEIGHTS = REAL(WEIGHTS_LOC, KIND=C_DOUBLE) - IERR = INT(IERR_LOC, KIND=C_INT) - - RETURN -END SUBROUTINE C_DELAUNAYSPARSEP_NOOPTS - - -SUBROUTINE C_DELAUNAYSPARSEP_INTERP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - IR, INTERP_IN, INTERP_OUT) & - BIND(C, NAME="c_delaunaysparsep_interp") - ! This is a wrapper for DELAUNAYSPARSEP with INTERP_IN and INTERP_OUT - ! specified, but no other optional arguments. Unlike the Fortran interface, - ! in this interface the dimension of the response variables (IR) must - ! be explicitly specified by an additional input, IR. - ! - ! - ! On input: - ! - ! D is the dimension of the space for PTS and Q. - ! - ! N is the number of data points in PTS. - ! - ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the - ! coordinates of a single data point in R^D. - ! - ! M is the number of interpolation points in Q. - ! - ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the - ! coordinates of a single interpolation point in R^D. - ! - ! IR is the dimension of the response variables. - ! - ! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of - ! the data points in PTS on input. The first dimension of INTERP_IN is - ! inferred to be the dimension of these response vectors, and the - ! second dimension must match N. - ! - ! - ! On output: - ! - ! PTS and Q have been rescaled and shifted. All the data points in PTS - ! are now contained in the unit hyperball in R^D, and the points in Q - ! have been shifted and scaled accordingly in relation to PTS. - ! - ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns - ! in PTS) for the D+1 vertices of the Delaunay simplex containing each - ! interpolation point in Q. - ! - ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each - ! point in Q as a convex combination of the D+1 corresponding vertices - ! in SIMPS. - ! - ! IERR(1:M) contains integer valued error flags associated with the - ! computation of each of the M interpolation points in Q. The error - ! codes are given in the definition of DELAUNAYSPARSEP in delsparse.f90. - ! - ! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each - ! interpolation point in Q on output. The first dimension of INTERP_OU - ! must match the first dimension of INTERP_IN, and the second dimension - ! must match M. - ! - ! - ! LAST UPDATE: - ! 11/2020 by THC - ! - USE REAL_PRECISION , ONLY : R8 - USE ISO_C_BINDING - - IMPLICIT NONE - - INTEGER(C_INT), INTENT(IN) :: D - INTEGER(C_INT), INTENT(IN) :: N - REAL(C_DOUBLE), INTENT(INOUT) :: PTS(D,N) - INTEGER(C_INT), INTENT(IN) :: M - REAL(C_DOUBLE), INTENT(INOUT) :: Q(D,M) - INTEGER(C_INT), INTENT(OUT) :: SIMPS(D+1,M) - REAL(C_DOUBLE), INTENT(OUT) :: WEIGHTS(D+1,M) - INTEGER(C_INT), INTENT(OUT) :: IERR(M) - INTEGER(C_INT), INTENT(IN) :: IR - REAL(C_DOUBLE), INTENT(IN) :: INTERP_IN(IR, N) - REAL(C_DOUBLE), INTENT(OUT) :: INTERP_OUT(IR, M) - - INTERFACE - SUBROUTINE DELAUNAYSPARSEP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, & - RNORM, IBUDGET, CHAIN, EXACT, PMODE) - USE REAL_PRECISION , ONLY : R8 - IMPLICIT NONE - INTEGER, INTENT(IN) :: D - INTEGER, INTENT(IN) :: N - REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) - INTEGER, INTENT(IN) :: M - REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) - INTEGER, INTENT(OUT) :: SIMPS(:,:) - REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) - INTEGER, INTENT(OUT) :: IERR(:) - REAL(KIND=R8), INTENT(IN), OPTIONAL :: INTERP_IN(:,:) - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) - INTEGER, INTENT(IN), OPTIONAL :: IBUDGET - LOGICAL, INTENT(IN), OPTIONAL :: CHAIN - LOGICAL, INTENT(IN), OPTIONAL :: EXACT - INTEGER, INTENT(IN), OPTIONAL :: PMODE - END SUBROUTINE DELAUNAYSPARSEP - END INTERFACE - - INTEGER :: D_LOC - INTEGER :: N_LOC - REAL(KIND=R8) :: PTS_LOC(D, N) - INTEGER :: M_LOC - REAL(KIND=R8) :: Q_LOC(D, M) - INTEGER :: SIMPS_LOC(D+1, M) - REAL(KIND=R8) :: WEIGHTS_LOC(D+1, M) - INTEGER :: IERR_LOC(M) - REAL(KIND=R8) :: INTERP_IN_LOC(IR, N) - REAL(KIND=R8) :: INTERP_OUT_LOC(IR, M) - - D_LOC = INT(D) - N_LOC = INT(N) - PTS_LOC = REAL(PTS, KIND=R8) - M_LOC = INT(M) - Q_LOC = REAL(Q, KIND=R8) - INTERP_IN_LOC = REAL(INTERP_IN, KIND=R8) - - CALL DELAUNAYSPARSEP(D_LOC, N_LOC, PTS_LOC, M_LOC, Q_LOC, SIMPS_LOC, & - WEIGHTS_LOC, IERR_LOC, INTERP_IN=INTERP_IN_LOC, & - INTERP_OUT=INTERP_OUT_LOC) - - PTS = REAL(PTS_LOC, KIND=C_DOUBLE) - Q = REAL(Q_LOC, KIND=C_DOUBLE) - SIMPS = INT(SIMPS_LOC, KIND=C_INT) - WEIGHTS = REAL(WEIGHTS_LOC, KIND=C_DOUBLE) - IERR = INT(IERR_LOC, KIND=C_INT) - INTERP_OUT = REAL(INTERP_OUT_LOC, KIND=C_DOUBLE) - - RETURN -END SUBROUTINE C_DELAUNAYSPARSEP_INTERP - - -SUBROUTINE C_DELAUNAYSPARSEP_OPTS(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, EPS, & - EXTRAP, RNORM, IBUDGET, CHAIN, EXACT, PMODE) & - BIND(C, NAME="c_delaunaysparsep_opts") - ! This is a wrapper for DELAUNAYSPARSEP without INTERP_IN and INTERP_OUT, - ! but all other optional arguments present. - ! - ! - ! On input: - ! - ! D is the dimension of the space for PTS and Q. - ! - ! N is the number of data points in PTS. - ! - ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the - ! coordinates of a single data point in R^D. - ! - ! M is the number of interpolation points in Q. - ! - ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the - ! coordinates of a single interpolation point in R^D. - ! - ! EXTRAP contains the real maximum extrapolation distance (relative to the - ! diameter of PTS) on input. Interpolation at a point outside the convex - ! hull of PTS is done by projecting that point onto the convex hull, and - ! then doing normal Delaunay interpolation at that projection. - ! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) - ! units outside the convex hull of PTS will not be done and an error code - ! of 2 will be returned. Note that computing the projection can be - ! expensive. Setting EXTRAP=0 will cause all extrapolation points to be - ! ignored without ever computing a projection. - ! - ! IBUDGET on input contains the integer budget for performing flips while - ! iterating toward the simplex containing each interpolation point in Q. - ! This prevents DELAUNAYSPARSEP from falling into an infinite loop when - ! an inappropriate value of EPS is given with respect to the problem - ! conditioning. For most cases, the default value of 50000 should be - ! more than sufficient. - ! - ! CHAIN is a logical input argument that determines whether a new first - ! simplex should be constructed for each interpolation point - ! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." - ! Setting CHAIN=.TRUE. is generally not recommended, unless the size of - ! the triangulation is relatively small or the interpolation points are - ! known to be tightly clustered. - ! - ! EXACT is a logical input argument that determines whether the exact - ! diameter should be computed and whether a check for duplicate data - ! points should be performed in advance. When EXACT=.FALSE., the - ! diameter of PTS is approximated by twice the distance from the - ! barycenter of PTS to the farthest point in PTS, and no check is - ! done to find the closest pair of points, which could result in hard - ! to find bugs later on. When EXACT=.TRUE., the exact diameter is - ! computed and an error is returned whenever PTS contains duplicate - ! values up to the precision EPS. Setting EXACT=.FALSE. could result - ! in significant speedup when N is large, but it is strongly - ! recommended that most users leave EXACT=.TRUE., as setting - ! EXACT=.FALSE. could result in input errors that are difficult - ! to identify. Also, the diameter approximation could be wrong by up - ! to a factor of two. - ! - ! PMODE is an integer specifying the level of parallelism to be exploited. - ! If PMODE = 1, then parallelism is exploited at the level of the loop - ! over all interpolation points (Level 1 parallelism). - ! If PMODE = 2, then parallelism is exploited at the level of the loops - ! over data points when constructing/flipping simplices (Level 2 - ! parallelism). - ! If PMODE = 3, then parallelism is exploited at both levels. Note: this - ! implies that the total number of threads active at any time could be up - ! to OMP_NUM_THREADS^2. - ! - ! - ! On output: - ! - ! PTS and Q have been rescaled and shifted. All the data points in PTS - ! are now contained in the unit hyperball in R^D, and the points in Q - ! have been shifted and scaled accordingly in relation to PTS. - ! - ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns - ! in PTS) for the D+1 vertices of the Delaunay simplex containing each - ! interpolation point in Q. - ! - ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each - ! point in Q as a convex combination of the D+1 corresponding vertices - ! in SIMPS. - ! - ! IERR(1:M) contains integer valued error flags associated with the - ! computation of each of the M interpolation points in Q. The error - ! codes are given in the definition of DELAUNAYSPARSEP in delsparse.f90. - ! - ! RNORM(1:M) contains the real unscaled projection (2-norm) distances from - ! any projection computations on output. - ! - ! - ! LAST UPDATE: - ! 11/2020 by THC - ! - USE REAL_PRECISION , ONLY : R8 - USE ISO_C_BINDING - - IMPLICIT NONE - - INTEGER(C_INT), INTENT(IN) :: D - INTEGER(C_INT), INTENT(IN) :: N - REAL(C_DOUBLE), INTENT(INOUT) :: PTS(D,N) - INTEGER(C_INT), INTENT(IN) :: M - REAL(C_DOUBLE), INTENT(INOUT) :: Q(D,M) - INTEGER(C_INT), INTENT(OUT) :: SIMPS(D+1,M) - REAL(C_DOUBLE), INTENT(OUT) :: WEIGHTS(D+1,M) - INTEGER(C_INT), INTENT(OUT) :: IERR(M) - REAL(C_DOUBLE), INTENT(IN) :: EPS - REAL(C_DOUBLE), INTENT(IN) :: EXTRAP - REAL(C_DOUBLE), INTENT(OUT) :: RNORM(M) - INTEGER(C_INT), INTENT(IN) :: IBUDGET - LOGICAL(C_BOOL), INTENT(IN) :: CHAIN - LOGICAL(C_BOOL), INTENT(IN) :: EXACT - INTEGER(C_INT), INTENT(IN) :: PMODE - - INTERFACE - SUBROUTINE DELAUNAYSPARSEP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, & - RNORM, IBUDGET, CHAIN, EXACT, PMODE) - USE REAL_PRECISION , ONLY : R8 - IMPLICIT NONE - INTEGER, INTENT(IN) :: D - INTEGER, INTENT(IN) :: N - REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) - INTEGER, INTENT(IN) :: M - REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) - INTEGER, INTENT(OUT) :: SIMPS(:,:) - REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) - INTEGER, INTENT(OUT) :: IERR(:) - REAL(KIND=R8), INTENT(IN), OPTIONAL :: INTERP_IN(:,:) - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) - INTEGER, INTENT(IN), OPTIONAL :: IBUDGET - LOGICAL, INTENT(IN), OPTIONAL :: CHAIN - LOGICAL, INTENT(IN), OPTIONAL :: EXACT - INTEGER, INTENT(IN), OPTIONAL :: PMODE - END SUBROUTINE DELAUNAYSPARSEP - END INTERFACE - - INTEGER :: D_LOC - INTEGER :: N_LOC - REAL(KIND=R8) :: PTS_LOC(D, N) - INTEGER :: M_LOC - REAL(KIND=R8) :: Q_LOC(D, M) - INTEGER :: SIMPS_LOC(D+1, M) - REAL(KIND=R8) :: WEIGHTS_LOC(D+1, M) - INTEGER :: IERR_LOC(M) - REAL(KIND=R8) :: EPS_LOC - REAL(KIND=R8) :: EXTRAP_LOC - REAL(KIND=R8) :: RNORM_LOC(M) - INTEGER :: IBUDGET_LOC - LOGICAL :: CHAIN_LOC - LOGICAL :: EXACT_LOC - INTEGER :: PMODE_LOC - - D_LOC = INT(D) - N_LOC = INT(N) - PTS_LOC = REAL(PTS, KIND=R8) - M_LOC = INT(M) - Q_LOC = REAL(Q, KIND=R8) - EPS_LOC = REAL(EPS, KIND=R8) - EXTRAP_LOC = REAL(EXTRAP, KIND=R8) - IBUDGET_LOC = INT(IBUDGET) - CHAIN_LOC = LOGICAL(CHAIN) - EXACT_LOC = LOGICAL(EXACT) - PMODE_LOC = INT(PMODE) - - CALL DELAUNAYSPARSEP(D_LOC, N_LOC, PTS_LOC, M_LOC, Q_LOC, SIMPS_LOC, & - WEIGHTS_LOC, IERR_LOC, EPS=EPS_LOC, & - EXTRAP=EXTRAP_LOC, RNORM=RNORM_LOC, & - IBUDGET=IBUDGET_LOC, CHAIN=CHAIN_LOC, & - EXACT=EXACT_LOC, PMODE=PMODE_LOC) - - PTS = REAL(PTS_LOC, KIND=C_DOUBLE) - Q = REAL(Q_LOC, KIND=C_DOUBLE) - SIMPS = INT(SIMPS_LOC, KIND=C_INT) - WEIGHTS = REAL(WEIGHTS_LOC, KIND=C_DOUBLE) - IERR = INT(IERR_LOC, KIND=C_INT) - RNORM = REAL(RNORM_LOC, KIND=C_DOUBLE) - - RETURN -END SUBROUTINE C_DELAUNAYSPARSEP_OPTS - - -SUBROUTINE C_DELAUNAYSPARSEP_INTERP_OPTS(D, N, PTS, M, Q, SIMPS, WEIGHTS, & - IERR, IR, INTERP_IN, INTERP_OUT, & - EPS, EXTRAP, RNORM, IBUDGET, CHAIN, & - EXACT, PMODE) & - BIND(C, NAME="c_delaunaysparsep_interp_opts") - ! This is a wrapper for DELAUNAYSPARSEP with all optional arguments present. - ! - ! - ! On input: - ! - ! D is the dimension of the space for PTS and Q. - ! - ! N is the number of data points in PTS. - ! - ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the - ! coordinates of a single data point in R^D. - ! - ! M is the number of interpolation points in Q. - ! - ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the - ! coordinates of a single interpolation point in R^D. - ! - ! IR is the dimension of the response variables. - ! - ! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of - ! the data points in PTS on input. The first dimension of INTERP_IN is - ! inferred to be the dimension of these response vectors, and the - ! second dimension must match N. - ! - ! EXTRAP contains the real maximum extrapolation distance (relative to the - ! diameter of PTS) on input. Interpolation at a point outside the convex - ! hull of PTS is done by projecting that point onto the convex hull, and - ! then doing normal Delaunay interpolation at that projection. - ! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) - ! units outside the convex hull of PTS will not be done and an error code - ! of 2 will be returned. Note that computing the projection can be - ! expensive. Setting EXTRAP=0 will cause all extrapolation points to be - ! ignored without ever computing a projection. - ! - ! IBUDGET on input contains the integer budget for performing flips while - ! iterating toward the simplex containing each interpolation point in Q. - ! This prevents DELAUNAYSPARSEP from falling into an infinite loop when - ! an inappropriate value of EPS is given with respect to the problem - ! conditioning. For most cases, the default value of 50000 should be - ! more than sufficient. - ! - ! CHAIN is a logical input argument that determines whether a new first - ! simplex should be constructed for each interpolation point - ! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." - ! Setting CHAIN=.TRUE. is generally not recommended, unless the size of - ! the triangulation is relatively small or the interpolation points are - ! known to be tightly clustered. - ! - ! EXACT is a logical input argument that determines whether the exact - ! diameter should be computed and whether a check for duplicate data - ! points should be performed in advance. When EXACT=.FALSE., the - ! diameter of PTS is approximated by twice the distance from the - ! barycenter of PTS to the farthest point in PTS, and no check is - ! done to find the closest pair of points, which could result in hard - ! to find bugs later on. When EXACT=.TRUE., the exact diameter is - ! computed and an error is returned whenever PTS contains duplicate - ! values up to the precision EPS. Setting EXACT=.FALSE. could result - ! in significant speedup when N is large, but it is strongly - ! recommended that most users leave EXACT=.TRUE., as setting - ! EXACT=.FALSE. could result in input errors that are difficult - ! to identify. Also, the diameter approximation could be wrong by up - ! to a factor of two. - ! - ! PMODE is an integer specifying the level of parallelism to be exploited. - ! If PMODE = 1, then parallelism is exploited at the level of the loop - ! over all interpolation points (Level 1 parallelism). - ! If PMODE = 2, then parallelism is exploited at the level of the loops - ! over data points when constructing/flipping simplices (Level 2 - ! parallelism). - ! If PMODE = 3, then parallelism is exploited at both levels. Note: this - ! implies that the total number of threads active at any time could be up - ! to OMP_NUM_THREADS^2. - ! - ! - ! On output: - ! - ! PTS and Q have been rescaled and shifted. All the data points in PTS - ! are now contained in the unit hyperball in R^D, and the points in Q - ! have been shifted and scaled accordingly in relation to PTS. - ! - ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns - ! in PTS) for the D+1 vertices of the Delaunay simplex containing each - ! interpolation point in Q. - ! - ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each - ! point in Q as a convex combination of the D+1 corresponding vertices - ! in SIMPS. - ! - ! IERR(1:M) contains integer valued error flags associated with the - ! computation of each of the M interpolation points in Q. The error - ! codes are given in the definition of DELAUNAYSPARSEP in delsparse.f90. - ! - ! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each - ! interpolation point in Q on output. The first dimension of INTERP_OUT - ! must match the first dimension of INTERP_IN, and the second dimension - ! must match M. - ! - ! RNORM(1:M) contains the real unscaled projection (2-norm) distances from - ! any projection computations on output. - ! - ! - ! LAST UPDATE: - ! 11/2020 by THC - ! - USE REAL_PRECISION , ONLY : R8 - USE ISO_C_BINDING - - IMPLICIT NONE - - INTEGER(C_INT), INTENT(IN) :: D - INTEGER(C_INT), INTENT(IN) :: N - REAL(C_DOUBLE), INTENT(INOUT) :: PTS(D,N) - INTEGER(C_INT), INTENT(IN) :: M - REAL(C_DOUBLE), INTENT(INOUT) :: Q(D,M) - INTEGER(C_INT), INTENT(OUT) :: SIMPS(D+1,M) - REAL(C_DOUBLE), INTENT(OUT) :: WEIGHTS(D+1,M) - INTEGER(C_INT), INTENT(OUT) :: IERR(M) - INTEGER(C_INT), INTENT(IN) :: IR - REAL(C_DOUBLE), INTENT(IN) :: INTERP_IN(IR, N) - REAL(C_DOUBLE), INTENT(OUT) :: INTERP_OUT(IR, M) - REAL(C_DOUBLE), INTENT(IN) :: EPS - REAL(C_DOUBLE), INTENT(IN) :: EXTRAP - REAL(C_DOUBLE), INTENT(OUT) :: RNORM(M) - INTEGER(C_INT), INTENT(IN) :: IBUDGET - LOGICAL(C_BOOL), INTENT(IN) :: CHAIN - LOGICAL(C_BOOL), INTENT(IN) :: EXACT - INTEGER(C_INT), INTENT(IN) :: PMODE - - INTERFACE - SUBROUTINE DELAUNAYSPARSEP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, & - RNORM, IBUDGET, CHAIN, EXACT, PMODE) - USE REAL_PRECISION , ONLY : R8 - IMPLICIT NONE - INTEGER, INTENT(IN) :: D - INTEGER, INTENT(IN) :: N - REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) - INTEGER, INTENT(IN) :: M - REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) - INTEGER, INTENT(OUT) :: SIMPS(:,:) - REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) - INTEGER, INTENT(OUT) :: IERR(:) - REAL(KIND=R8), INTENT(IN), OPTIONAL :: INTERP_IN(:,:) - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) - INTEGER, INTENT(IN), OPTIONAL :: IBUDGET - LOGICAL, INTENT(IN), OPTIONAL :: CHAIN - LOGICAL, INTENT(IN), OPTIONAL :: EXACT - INTEGER, INTENT(IN), OPTIONAL :: PMODE - END SUBROUTINE DELAUNAYSPARSEP - END INTERFACE - - INTEGER :: D_LOC - INTEGER :: N_LOC - REAL(KIND=R8) :: PTS_LOC(D, N) - INTEGER :: M_LOC - REAL(KIND=R8) :: Q_LOC(D, M) - INTEGER :: SIMPS_LOC(D+1, M) - REAL(KIND=R8) :: WEIGHTS_LOC(D+1, M) - INTEGER :: IERR_LOC(M) - REAL(KIND=R8) :: INTERP_IN_LOC(IR, N) - REAL(KIND=R8) :: INTERP_OUT_LOC(IR, M) - REAL(KIND=R8) :: EPS_LOC - REAL(KIND=R8) :: EXTRAP_LOC - REAL(KIND=R8) :: RNORM_LOC(M) - INTEGER :: IBUDGET_LOC - LOGICAL :: CHAIN_LOC - LOGICAL :: EXACT_LOC - INTEGER :: PMODE_LOC - - D_LOC = INT(D) - N_LOC = INT(N) - PTS_LOC = REAL(PTS, KIND=R8) - M_LOC = INT(M) - Q_LOC = REAL(Q, KIND=R8) - INTERP_IN_LOC = REAL(INTERP_IN, KIND=R8) - EPS_LOC = REAL(EPS, KIND=R8) - EXTRAP_LOC = REAL(EXTRAP, KIND=R8) - IBUDGET_LOC = INT(IBUDGET) - CHAIN_LOC = LOGICAL(CHAIN) - EXACT_LOC = LOGICAL(EXACT) - PMODE_LOC = INT(PMODE) - - CALL DELAUNAYSPARSEP(D_LOC, N_LOC, PTS_LOC, M_LOC, Q_LOC, SIMPS_LOC, & - WEIGHTS_LOC, IERR_LOC, INTERP_IN=INTERP_IN_LOC, & - INTERP_OUT=INTERP_OUT_LOC, EPS=EPS_LOC, & - EXTRAP=EXTRAP_LOC, RNORM=RNORM_LOC, & - IBUDGET=IBUDGET_LOC, CHAIN=CHAIN_LOC, & - EXACT=EXACT_LOC, PMODE=PMODE_LOC) - - PTS = REAL(PTS_LOC, KIND=C_DOUBLE) - Q = REAL(Q_LOC, KIND=C_DOUBLE) - SIMPS = INT(SIMPS_LOC, KIND=C_INT) - WEIGHTS = REAL(WEIGHTS_LOC, KIND=C_DOUBLE) - IERR = INT(IERR_LOC, KIND=C_INT) - INTERP_OUT = REAL(INTERP_OUT_LOC, C_DOUBLE) - RNORM = REAL(RNORM_LOC, KIND=C_DOUBLE) - - RETURN -END SUBROUTINE C_DELAUNAYSPARSEP_INTERP_OPTS - diff --git a/extras/c_binding/dependencies/blas.f b/extras/c_binding/dependencies/blas.f deleted file mode 100644 index df991ff..0000000 --- a/extras/c_binding/dependencies/blas.f +++ /dev/null @@ -1,2206 +0,0 @@ - -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* ====================================== - - DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* Purpose: -* ============= -* -* DASUM takes the sum of the absolute values. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 3/93 to return if incx .le. 0. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,M,MP1,NINCX -* .. -* .. Intrinsic Functions .. - INTRINSIC DABS,MOD -* .. - DASUM = 0.0D0 - DTEMP = 0.0D0 - IF (N.LE.0 .OR. INCX.LE.0) RETURN - IF (INCX.EQ.1) THEN -* code for increment equal to 1 -* -* -* clean-up loop -* - M = MOD(N,6) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DTEMP + DABS(DX(I)) - END DO - IF (N.LT.6) THEN - DASUM = DTEMP - RETURN - END IF - END IF - MP1 = M + 1 - DO I = MP1,N,6 - DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) + - $ DABS(DX(I+2)) + DABS(DX(I+3)) + - $ DABS(DX(I+4)) + DABS(DX(I+5)) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - DTEMP = DTEMP + DABS(DX(I)) - END DO - END IF - DASUM = DTEMP - RETURN - END - - SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - DOUBLE PRECISION DA - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* Purpose: -* ============= -* -* DAXPY constant times a vector plus a vector. -* uses unrolled loops for increments equal to one. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DA is DOUBLE PRECISION. On entry, DA specifies the scalar alpha. -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -* -* INCY is INTEGER storage spacing between elements of DY -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (DA.EQ.0.0D0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,4) - IF (M.NE.0) THEN - DO I = 1,M - DY(I) = DY(I) + DA*DX(I) - END DO - END IF - IF (N.LT.4) RETURN - MP1 = M + 1 - DO I = MP1,N,4 - DY(I) = DY(I) + DA*DX(I) - DY(I+1) = DY(I+1) + DA*DX(I+1) - DY(I+2) = DY(I+2) + DA*DX(I+2) - DY(I+3) = DY(I+3) + DA*DX(I+3) - END DO - ELSE -* -* code for unequal increments or equal increments -* 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 I = 1,N - DY(IY) = DY(IY) + DA*DX(IX) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN - END - - SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* Purpose: -* ============= -* -* DCOPY copies a vector, x, to a vector, y. -* uses unrolled loops for increments equal to 1. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -* -* INCY is INTEGER storage spacing between elements of DY -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,7) - IF (M.NE.0) THEN - DO I = 1,M - DY(I) = DX(I) - END DO - IF (N.LT.7) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,7 - DY(I) = DX(I) - DY(I+1) = DX(I+1) - DY(I+2) = DX(I+2) - DY(I+3) = DX(I+3) - DY(I+4) = DX(I+4) - DY(I+5) = DX(I+5) - DY(I+6) = DX(I+6) - END DO - ELSE -* -* code for unequal increments or equal increments -* 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 I = 1,N - DY(IY) = DX(IX) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN - END - - DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* Purpose: -* ============= -* -* DDOT forms the dot product of two vectors. -* uses unrolled loops for increments equal to one. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -* -* INCY is INTEGER storage spacing between elements of DY -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - DDOT = 0.0D0 - DTEMP = 0.0D0 - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,5) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DTEMP + DX(I)*DY(I) - END DO - IF (N.LT.5) THEN - DDOT=DTEMP - RETURN - END IF - END IF - MP1 = M + 1 - DO I = MP1,N,5 - DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) + - $ DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) - END DO - ELSE -* -* code for unequal increments or equal increments -* 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 I = 1,N - DTEMP = DTEMP + DX(IX)*DY(IY) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - DDOT = DTEMP - RETURN - END - - SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* -- Reference BLAS level3 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of -* Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER K,LDA,LDB,LDC,M,N - CHARACTER TRANSA,TRANSB -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB - LOGICAL NOTA,NOTB -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Set NOTA and NOTB as true if A and B respectively are -* not -* transposed and set NROWA, NCOLA and NROWB as the number of -* rows -* and columns of A and the number of rows of B -* respectively. -* - NOTA = LSAME(TRANSA,'N') - NOTB = LSAME(TRANSB,'N') - IF (NOTA) THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - END IF - IF (NOTB) THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. - + (.NOT.LSAME(TRANSA,'T'))) THEN - INFO = 1 - ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. - + (.NOT.LSAME(TRANSB,'T'))) THEN - INFO = 2 - ELSE IF (M.LT.0) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (K.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 8 - ELSE IF (LDB.LT.MAX(1,NROWB)) THEN - INFO = 10 - ELSE IF (LDC.LT.MAX(1,M)) THEN - INFO = 13 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGEMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN -* -* And if alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,M - C(I,J) = BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF (NOTB) THEN - IF (NOTA) THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 50 I = 1,M - C(I,J) = ZERO - 50 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 60 I = 1,M - C(I,J) = BETA*C(I,J) - 60 CONTINUE - END IF - DO 80 L = 1,K - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - ELSE -* -* Form C := alpha*A**T*B + beta*C -* - DO 120 J = 1,N - DO 110 I = 1,M - TEMP = ZERO - DO 100 L = 1,K - TEMP = TEMP + A(L,I)*B(L,J) - 100 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 110 CONTINUE - 120 CONTINUE - END IF - ELSE - IF (NOTA) THEN -* -* Form C := alpha*A*B**T + beta*C -* - DO 170 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 130 I = 1,M - C(I,J) = ZERO - 130 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 140 I = 1,M - C(I,J) = BETA*C(I,J) - 140 CONTINUE - END IF - DO 160 L = 1,K - TEMP = ALPHA*B(J,L) - DO 150 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - ELSE -* -* Form C := alpha*A**T*B**T + beta*C -* - DO 200 J = 1,N - DO 190 I = 1,M - TEMP = ZERO - DO 180 L = 1,K - TEMP = TEMP + A(L,I)*B(J,L) - 180 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 190 CONTINUE - 200 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMM . -* - END - - SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* -- Reference BLAS level2 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER INCX,INCY,LDA,M,N - CHARACTER TRANS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* Purpose: -* ============= -* -* DGEMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n matrix. -* -* Arguments: -* ========== -* -* TRANS is CHARACTER*1 -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. -* M is INTEGER -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* -* N is INTEGER -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* -* ALPHA is DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* -* A is DOUBLE PRECISION array, dimension ( LDA, N ) -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. -* -* LDA is INTEGER -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* -* X is DOUBLE PRECISION array, dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* -* INCX is INTEGER -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* -* BETA is DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* -* Y is DOUBLE PRECISION array, dimension at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry with BETA non-zero, the incremented array Y -* must contain the vector y. On exit, Y is overwritten by the -* updated vector y. -* -* INCY is INTEGER -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* -* Further Details: -* ===================== -* -* Level 2 Blas routine. -* The vector and matrix arguments are not referenced when N = 0, or M = 0 -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 1 - ELSE IF (M.LT.0) THEN - INFO = 2 - ELSE IF (N.LT.0) THEN - INFO = 3 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - ELSE IF (INCY.EQ.0) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGEMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF (LSAME(TRANS,'N')) THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (LENX-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (LENY-1)*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF (BETA.NE.ONE) THEN - IF (INCY.EQ.1) THEN - IF (BETA.EQ.ZERO) THEN - DO 10 I = 1,LENY - Y(I) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1,LENY - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ELSE - IY = KY - IF (BETA.EQ.ZERO) THEN - DO 30 I = 1,LENY - Y(IY) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1,LENY - Y(IY) = BETA*Y(IY) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF (ALPHA.EQ.ZERO) RETURN - IF (LSAME(TRANS,'N')) THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF (INCY.EQ.1) THEN - DO 60 J = 1,N - TEMP = ALPHA*X(JX) - DO 50 I = 1,M - Y(I) = Y(I) + TEMP*A(I,J) - 50 CONTINUE - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80 J = 1,N - TEMP = ALPHA*X(JX) - IY = KY - DO 70 I = 1,M - Y(IY) = Y(IY) + TEMP*A(I,J) - IY = IY + INCY - 70 CONTINUE - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A**T*x + y. -* - JY = KY - IF (INCX.EQ.1) THEN - DO 100 J = 1,N - TEMP = ZERO - DO 90 I = 1,M - TEMP = TEMP + A(I,J)*X(I) - 90 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120 J = 1,N - TEMP = ZERO - IX = KX - DO 110 I = 1,M - TEMP = TEMP + A(I,J)*X(IX) - IX = IX + INCX - 110 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMV . -* - END - - SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* -- Reference BLAS level2 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of -* Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX,INCY,LDA,M,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER(ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,J,JY,KX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (M.LT.0) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (INCX.EQ.0) THEN - INFO = 5 - ELSE IF (INCY.EQ.0) THEN - INFO = 7 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGER ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (INCY.GT.0) THEN - JY = 1 - ELSE - JY = 1 - (N-1)*INCY - END IF - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*Y(JY) - DO 10 I = 1,M - A(I,J) = A(I,J) + X(I)*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (M-1)*INCX - END IF - DO 40 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*Y(JY) - IX = KX - DO 30 I = 1,M - A(I,J) = A(I,J) + X(IX)*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of DGER . -* - END - - DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION X(*) -* .. -* -* Purpose: -* ============= -* -* DNRM2 returns the euclidean norm of a vector via the function -* name, so that -* -* DNRM2 := sqrt( x'*x ) -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* Further Details: -* ===================== -* -* -- This version written on 25-October-1982. -* Modified on 14-October-1993 to inline the call to DLASSQ. -* Sven Hammarling, Nag Ltd. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ - INTEGER IX -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS,SQRT -* .. - IF (N.LT.1 .OR. INCX.LT.1) THEN - NORM = ZERO - ELSE IF (N.EQ.1) THEN - NORM = ABS(X(1)) - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10 IX = 1,1 + (N-1)*INCX,INCX - IF (X(IX).NE.ZERO) THEN - ABSXI = ABS(X(IX)) - IF (SCALE.LT.ABSXI) THEN - SSQ = ONE + SSQ* (SCALE/ABSXI)**2 - SCALE = ABSXI - ELSE - SSQ = SSQ + (ABSXI/SCALE)**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE*SQRT(SSQ) - END IF -* - DNRM2 = NORM - RETURN -* -* End of DNRM2. -* - END - - SUBROUTINE DSCAL(N,DA,DX,INCX) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - DOUBLE PRECISION DA - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* Purpose: -* ============= -* -* DSCAL scales a vector by a constant. -* uses unrolled loops for increment equal to 1. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DA is DOUBLE PRECISION On entry, DA specifies the scalar alpha. -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 3/93 to return if incx .le. 0. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,M,MP1,NINCX -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0 .OR. INCX.LE.0) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* -* -* clean-up loop -* - M = MOD(N,5) - IF (M.NE.0) THEN - DO I = 1,M - DX(I) = DA*DX(I) - END DO - IF (N.LT.5) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,5 - DX(I) = DA*DX(I) - DX(I+1) = DA*DX(I+1) - DX(I+2) = DA*DX(I+2) - DX(I+3) = DA*DX(I+3) - DX(I+4) = DA*DX(I+4) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - DX(I) = DA*DX(I) - END DO - END IF - RETURN - END - - SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* Purpose: -* ============= -* -* DSWAP interchanges two vectors. -* uses unrolled loops for increments equal to 1. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -* -* INCY is INTEGER storage spacing between elements of DY -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,3) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - END DO - IF (N.LT.3) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,3 - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - DTEMP = DX(I+1) - DX(I+1) = DY(I+1) - DY(I+1) = DTEMP - DTEMP = DX(I+2) - DX(I+2) = DY(I+2) - DY(I+2) = DTEMP - END DO - ELSE -* -* code for unequal increments or equal increments 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 I = 1,N - DTEMP = DX(IX) - DX(IX) = DY(IY) - DY(IY) = DTEMP - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN - END - - SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* -- Reference BLAS level3 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of -* Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER LDA,LDB,M,N - CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,K,NROWA - LOGICAL LSIDE,NOUNIT,UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Test the input parameters. -* - LSIDE = LSAME(SIDE,'L') - IF (LSIDE) THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME(DIAG,'N') - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN - INFO = 1 - ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 2 - ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. - + (.NOT.LSAME(TRANSA,'T')) .AND. - + (.NOT.LSAME(TRANSA,'C'))) THEN - INFO = 3 - ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN - INFO = 4 - ELSE IF (M.LT.0) THEN - INFO = 5 - ELSE IF (N.LT.0) THEN - INFO = 6 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDB.LT.MAX(1,M)) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (M.EQ.0 .OR. N.EQ.0) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - B(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF (LSIDE) THEN - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*A*B. -* - IF (UPPER) THEN - DO 50 J = 1,N - DO 40 K = 1,M - IF (B(K,J).NE.ZERO) THEN - TEMP = ALPHA*B(K,J) - DO 30 I = 1,K - 1 - B(I,J) = B(I,J) + TEMP*A(I,K) - 30 CONTINUE - IF (NOUNIT) TEMP = TEMP*A(K,K) - B(K,J) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80 J = 1,N - DO 70 K = M,1,-1 - IF (B(K,J).NE.ZERO) THEN - TEMP = ALPHA*B(K,J) - B(K,J) = TEMP - IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) - DO 60 I = K + 1,M - B(I,J) = B(I,J) + TEMP*A(I,K) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A**T*B. -* - IF (UPPER) THEN - DO 110 J = 1,N - DO 100 I = M,1,-1 - TEMP = B(I,J) - IF (NOUNIT) TEMP = TEMP*A(I,I) - DO 90 K = 1,I - 1 - TEMP = TEMP + A(K,I)*B(K,J) - 90 CONTINUE - B(I,J) = ALPHA*TEMP - 100 CONTINUE - 110 CONTINUE - ELSE - DO 140 J = 1,N - DO 130 I = 1,M - TEMP = B(I,J) - IF (NOUNIT) TEMP = TEMP*A(I,I) - DO 120 K = I + 1,M - TEMP = TEMP + A(K,I)*B(K,J) - 120 CONTINUE - B(I,J) = ALPHA*TEMP - 130 CONTINUE - 140 CONTINUE - END IF - END IF - ELSE - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*B*A. -* - IF (UPPER) THEN - DO 180 J = N,1,-1 - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 150 I = 1,M - B(I,J) = TEMP*B(I,J) - 150 CONTINUE - DO 170 K = 1,J - 1 - IF (A(K,J).NE.ZERO) THEN - TEMP = ALPHA*A(K,J) - DO 160 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - ELSE - DO 220 J = 1,N - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 190 I = 1,M - B(I,J) = TEMP*B(I,J) - 190 CONTINUE - DO 210 K = J + 1,N - IF (A(K,J).NE.ZERO) THEN - TEMP = ALPHA*A(K,J) - DO 200 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 200 CONTINUE - END IF - 210 CONTINUE - 220 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A**T. -* - IF (UPPER) THEN - DO 260 K = 1,N - DO 240 J = 1,K - 1 - IF (A(J,K).NE.ZERO) THEN - TEMP = ALPHA*A(J,K) - DO 230 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 230 CONTINUE - END IF - 240 CONTINUE - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(K,K) - IF (TEMP.NE.ONE) THEN - DO 250 I = 1,M - B(I,K) = TEMP*B(I,K) - 250 CONTINUE - END IF - 260 CONTINUE - ELSE - DO 300 K = N,1,-1 - DO 280 J = K + 1,N - IF (A(J,K).NE.ZERO) THEN - TEMP = ALPHA*A(J,K) - DO 270 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 270 CONTINUE - END IF - 280 CONTINUE - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(K,K) - IF (TEMP.NE.ONE) THEN - DO 290 I = 1,M - B(I,K) = TEMP*B(I,K) - 290 CONTINUE - END IF - 300 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMM . -* - END - - SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* -- Reference BLAS level2 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of -* Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER INCX,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER(ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,J,JX,KX - LOGICAL NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := A*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - DO 10 I = 1,J - 1 - X(I) = X(I) + TEMP*A(I,J) - 10 CONTINUE - IF (NOUNIT) X(J) = X(J)*A(J,J) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 30 I = 1,J - 1 - X(IX) = X(IX) + TEMP*A(I,J) - IX = IX + INCX - 30 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*A(J,J) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - DO 50 I = N,J + 1,-1 - X(I) = X(I) + TEMP*A(I,J) - 50 CONTINUE - IF (NOUNIT) X(J) = X(J)*A(J,J) - END IF - 60 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 80 J = N,1,-1 - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 70 I = N,J + 1,-1 - X(IX) = X(IX) + TEMP*A(I,J) - IX = IX - INCX - 70 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*A(J,J) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A**T*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 100 J = N,1,-1 - TEMP = X(J) - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 90 I = J - 1,1,-1 - TEMP = TEMP + A(I,J)*X(I) - 90 CONTINUE - X(J) = TEMP - 100 CONTINUE - ELSE - JX = KX + (N-1)*INCX - DO 120 J = N,1,-1 - TEMP = X(JX) - IX = JX - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 110 I = J - 1,1,-1 - IX = IX - INCX - TEMP = TEMP + A(I,J)*X(IX) - 110 CONTINUE - X(JX) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 140 J = 1,N - TEMP = X(J) - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 130 I = J + 1,N - TEMP = TEMP + A(I,J)*X(I) - 130 CONTINUE - X(J) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160 J = 1,N - TEMP = X(JX) - IX = JX - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 150 I = J + 1,N - IX = IX + INCX - TEMP = TEMP + A(I,J)*X(IX) - 150 CONTINUE - X(JX) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMV . -* - END - - SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* -- Reference BLAS level3 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER LDA,LDB,M,N - CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*) -* .. -* -* Purpose: -* ============= -* -* DTRSM solves one of the matrix equations -* -* op( A )*X = alpha*B, or X*op( A ) = alpha*B, -* -* where alpha is a scalar, X and B are m by n matrices, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A**T. -* -* The matrix X is overwritten on B. -* -* Arguments: -* ========== -* -* SIDE is CHARACTER*1 -* On entry, SIDE specifies whether op( A ) appears on the left -* or right of X as follows: -* -* SIDE = 'L' or 'l' op( A )*X = alpha*B. -* -* SIDE = 'R' or 'r' X*op( A ) = alpha*B. -* -* UPLO is CHARACTER*1 -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* TRANSA is CHARACTER*1 -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n' op( A ) = A. -* -* TRANSA = 'T' or 't' op( A ) = A**T. -* -* TRANSA = 'C' or 'c' op( A ) = A**T. -* -* DIAG is CHARACTER*1 -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* M is INTEGER -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* -* N is INTEGER -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* -* ALPHA is DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* -* A is DOUBLE PRECISION array, dimension ( LDA, k ), -* where k is m when SIDE = 'L' or 'l' -* and k is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* -* LDA is INTEGER -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* -* B is DOUBLE PRECISION array, dimension ( LDB, N ) -* Before entry, the leading m by n part of the array B must -* contain the right-hand side matrix B, and on exit is -* overwritten by the solution matrix X. -* -* LDB is INTEGER -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* -* Further Details: -* ===================== -* -* Level 3 Blas routine. -* -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,K,NROWA - LOGICAL LSIDE,NOUNIT,UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Test the input parameters. -* - LSIDE = LSAME(SIDE,'L') - IF (LSIDE) THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME(DIAG,'N') - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN - INFO = 1 - ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 2 - ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. - + (.NOT.LSAME(TRANSA,'T')) .AND. - + (.NOT.LSAME(TRANSA,'C'))) THEN - INFO = 3 - ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN - INFO = 4 - ELSE IF (M.LT.0) THEN - INFO = 5 - ELSE IF (N.LT.0) THEN - INFO = 6 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDB.LT.MAX(1,M)) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRSM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (M.EQ.0 .OR. N.EQ.0) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - B(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF (LSIDE) THEN - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*inv( A )*B. -* - IF (UPPER) THEN - DO 60 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 30 I = 1,M - B(I,J) = ALPHA*B(I,J) - 30 CONTINUE - END IF - DO 50 K = M,1,-1 - IF (B(K,J).NE.ZERO) THEN - IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) - DO 40 I = 1,K - 1 - B(I,J) = B(I,J) - B(K,J)*A(I,K) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 70 I = 1,M - B(I,J) = ALPHA*B(I,J) - 70 CONTINUE - END IF - DO 90 K = 1,M - IF (B(K,J).NE.ZERO) THEN - IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) - DO 80 I = K + 1,M - B(I,J) = B(I,J) - B(K,J)*A(I,K) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A**T )*B. -* - IF (UPPER) THEN - DO 130 J = 1,N - DO 120 I = 1,M - TEMP = ALPHA*B(I,J) - DO 110 K = 1,I - 1 - TEMP = TEMP - A(K,I)*B(K,J) - 110 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(I,I) - B(I,J) = TEMP - 120 CONTINUE - 130 CONTINUE - ELSE - DO 160 J = 1,N - DO 150 I = M,1,-1 - TEMP = ALPHA*B(I,J) - DO 140 K = I + 1,M - TEMP = TEMP - A(K,I)*B(K,J) - 140 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(I,I) - B(I,J) = TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*B*inv( A ). -* - IF (UPPER) THEN - DO 210 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 170 I = 1,M - B(I,J) = ALPHA*B(I,J) - 170 CONTINUE - END IF - DO 190 K = 1,J - 1 - IF (A(K,J).NE.ZERO) THEN - DO 180 I = 1,M - B(I,J) = B(I,J) - A(K,J)*B(I,K) - 180 CONTINUE - END IF - 190 CONTINUE - IF (NOUNIT) THEN - TEMP = ONE/A(J,J) - DO 200 I = 1,M - B(I,J) = TEMP*B(I,J) - 200 CONTINUE - END IF - 210 CONTINUE - ELSE - DO 260 J = N,1,-1 - IF (ALPHA.NE.ONE) THEN - DO 220 I = 1,M - B(I,J) = ALPHA*B(I,J) - 220 CONTINUE - END IF - DO 240 K = J + 1,N - IF (A(K,J).NE.ZERO) THEN - DO 230 I = 1,M - B(I,J) = B(I,J) - A(K,J)*B(I,K) - 230 CONTINUE - END IF - 240 CONTINUE - IF (NOUNIT) THEN - TEMP = ONE/A(J,J) - DO 250 I = 1,M - B(I,J) = TEMP*B(I,J) - 250 CONTINUE - END IF - 260 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A**T ). -* - IF (UPPER) THEN - DO 310 K = N,1,-1 - IF (NOUNIT) THEN - TEMP = ONE/A(K,K) - DO 270 I = 1,M - B(I,K) = TEMP*B(I,K) - 270 CONTINUE - END IF - DO 290 J = 1,K - 1 - IF (A(J,K).NE.ZERO) THEN - TEMP = A(J,K) - DO 280 I = 1,M - B(I,J) = B(I,J) - TEMP*B(I,K) - 280 CONTINUE - END IF - 290 CONTINUE - IF (ALPHA.NE.ONE) THEN - DO 300 I = 1,M - B(I,K) = ALPHA*B(I,K) - 300 CONTINUE - END IF - 310 CONTINUE - ELSE - DO 360 K = 1,N - IF (NOUNIT) THEN - TEMP = ONE/A(K,K) - DO 320 I = 1,M - B(I,K) = TEMP*B(I,K) - 320 CONTINUE - END IF - DO 340 J = K + 1,N - IF (A(J,K).NE.ZERO) THEN - TEMP = A(J,K) - DO 330 I = 1,M - B(I,J) = B(I,J) - TEMP*B(I,K) - 330 CONTINUE - END IF - 340 CONTINUE - IF (ALPHA.NE.ONE) THEN - DO 350 I = 1,M - B(I,K) = ALPHA*B(I,K) - 350 CONTINUE - END IF - 360 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSM . -* - END - - INTEGER FUNCTION IDAMAX(N,DX,INCX) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* Purpose: -* ============= -* -* IDAMAX finds the index of the first element having maximum absolute value. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of SX -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 3/93 to return if incx .le. 0. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DMAX - INTEGER I,IX -* .. -* .. Intrinsic Functions .. - INTRINSIC DABS -* .. - IDAMAX = 0 - IF (N.LT.1 .OR. INCX.LE.0) RETURN - IDAMAX = 1 - IF (N.EQ.1) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* - DMAX = DABS(DX(1)) - DO I = 2,N - IF (DABS(DX(I)).GT.DMAX) THEN - IDAMAX = I - DMAX = DABS(DX(I)) - END IF - END DO - ELSE -* -* code for increment not equal to 1 -* - IX = 1 - DMAX = DABS(DX(1)) - IX = IX + INCX - DO I = 2,N - IF (DABS(DX(IX)).GT.DMAX) THEN - IDAMAX = I - DMAX = DABS(DX(IX)) - END IF - IX = IX + INCX - END DO - END IF - RETURN - END - - LOGICAL FUNCTION LSAME(CA,CB) -* -* -- Reference BLAS level1 routine (version 3.1) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - CHARACTER CA,CB -* .. -* -* Purpose: -* ============= -* -* LSAME returns .TRUE. if CA is the same letter as CB regardless of -* case. -* -* Arguments: -* ========== -* -* CA is CHARACTER*1 -* CB is CHARACTER*1 -* CA and CB specify the single characters to be compared. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ICHAR -* .. -* .. Local Scalars .. - INTEGER INTA,INTB,ZCODE -* .. -* -* Test if the characters are equal -* - LSAME = CA .EQ. CB - IF (LSAME) RETURN -* -* Now test for equivalence if both characters are alphabetic. -* - ZCODE = ICHAR('Z') -* -* Use 'Z' rather than 'A' so that ASCII can be detected on Prime -* machines, on which ICHAR returns a value with bit 8 set. -* ICHAR('A') on Prime machines returns 193 which is the same as -* ICHAR('A') on an EBCDIC machine. -* - INTA = ICHAR(CA) - INTB = ICHAR(CB) -* - IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN -* -* ASCII is assumed - ZCODE is the ASCII code of either lower or -* upper case 'Z'. -* - IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 - IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 -* - ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN -* -* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or -* upper case 'Z'. -* - IF (INTA.GE.129 .AND. INTA.LE.137 .OR. - + INTA.GE.145 .AND. INTA.LE.153 .OR. - + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 - IF (INTB.GE.129 .AND. INTB.LE.137 .OR. - + INTB.GE.145 .AND. INTB.LE.153 .OR. - + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 -* - ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN -* -* ASCII is assumed, on Prime machines - ZCODE is the ASCII code -* plus 128 of either lower or upper case 'Z'. -* - IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 - IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 - END IF - LSAME = INTA .EQ. INTB -* -* RETURN -* -* End of LSAME -* - END - - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* -- Reference BLAS level1 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - CHARACTER*(*) SRNAME - INTEGER INFO -* .. -* -* Purpose: -* ============= -* -* XERBLA is an error handler for the LAPACK routines. -* It is called by an LAPACK routine if an input parameter has an -* invalid value. A message is printed and execution stops. -* -* Installers may consider modifying the STOP statement in order to -* call system-specific exception-handling facilities. -* -* Arguments: -* ========== -* -* SRNAME is CHARACTER*(*) -* The name of the routine which called XERBLA. -* -* INFO is INTEGER -* The position of the invalid parameter in the parameter list -* of the calling routine. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC LEN_TRIM -* .. -* .. Executable Statements .. -* - WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO -* - STOP -* - 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', - $ 'an illegal value' ) -* -* End of XERBLA -* - END - diff --git a/extras/c_binding/dependencies/lapack.f b/extras/c_binding/dependencies/lapack.f deleted file mode 100644 index 3dff8b8..0000000 --- a/extras/c_binding/dependencies/lapack.f +++ /dev/null @@ -1,4369 +0,0 @@ - SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine (version 3.7.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -* -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER INB, INBMIN, IXOVER - PARAMETER( INB = 1, INBMIN = 2, IXOVER = 3 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, - $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN -* .. -* .. External Subroutines .. - EXTERNAL DGEQRF, DLAQP2, DLAQPS, DORMQR, DSWAP, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - DOUBLE PRECISION DNRM2 - EXTERNAL ILAENV, DNRM2 -* .. -* .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test input arguments -* ==================== -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF -* - IF( INFO.EQ.0 ) THEN - MINMN = MIN( M, N ) - IF( MINMN.EQ.0 ) THEN - IWS = 1 - LWKOPT = 1 - ELSE - IWS = 3*N + 1 - NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) - LWKOPT = 2*N + ( N + 1 )*NB - END IF - WORK( 1 ) = LWKOPT -* - IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQP3', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Move initial columns up front. -* - NFXD = 1 - DO 10 J = 1, N - IF( JPVT( J ).NE.0 ) THEN - IF( J.NE.NFXD ) THEN - CALL DSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 ) - JPVT( J ) = JPVT( NFXD ) - JPVT( NFXD ) = J - ELSE - JPVT( J ) = J - END IF - NFXD = NFXD + 1 - ELSE - JPVT( J ) = J - END IF - 10 CONTINUE - NFXD = NFXD - 1 -* -* Factorize fixed columns -* ======================= -* -* Compute the QR factorization of fixed columns and update -* remaining columns. -* - IF( NFXD.GT.0 ) THEN - NA = MIN( M, NFXD ) -*CC CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) - CALL DGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO ) - IWS = MAX( IWS, INT( WORK( 1 ) ) ) - IF( NA.LT.N ) THEN -*CC CALL DORM2R( 'LEFT', 'TRANSPOSE', M, N-NA, NA, A, LDA, -*CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) - CALL DORMQR( 'LEFT', 'TRANSPOSE', M, N-NA, NA, A, LDA, TAU, - $ A( 1, NA+1 ), LDA, WORK, LWORK, INFO ) - IWS = MAX( IWS, INT( WORK( 1 ) ) ) - END IF - END IF -* -* Factorize free columns -* ====================== -* - IF( NFXD.LT.MINMN ) THEN -* - SM = M - NFXD - SN = N - NFXD - SMINMN = MINMN - NFXD -* -* Determine the block size. -* - NB = ILAENV( INB, 'DGEQRF', ' ', SM, SN, -1, -1 ) - NBMIN = 2 - NX = 0 -* - IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN -* -* Determine when to cross over from blocked to unblocked -* code. -* - NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', SM, SN, -1, - $ -1 ) ) -* -* - IF( NX.LT.SMINMN ) THEN -* -* Determine if workspace is large enough for blocked code. -* - MINWS = 2*SN + ( SN+1 )*NB - IWS = MAX( IWS, MINWS ) - IF( LWORK.LT.MINWS ) THEN -* -* Not enough workspace to use optimal NB: Reduce NB and -* determine the minimum value of NB. -* - NB = ( LWORK-2*SN ) / ( SN+1 ) - NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', SM, N, - $ -1, -1 ) ) -* -* - END IF - END IF - END IF -* -* Initialize partial column norms. The first N elements of work -* store the exact column norms. -* - DO 20 J = NFXD + 1, N - WORK( J ) = DNRM2( SM, A( NFXD+1, J ), 1 ) - WORK( N+J ) = WORK( J ) - 20 CONTINUE -* - IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. - $ ( NX.LT.SMINMN ) ) THEN -* -* Use blocked code initially. -* - J = NFXD + 1 -* -* Compute factorization: while loop. -* -* - TOPBMN = MINMN - NX - 30 CONTINUE - IF( J.LE.TOPBMN ) THEN - JB = MIN( NB, TOPBMN-J+1 ) -* -* Factorize JB columns among columns J:N. -* - CALL DLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, - $ JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ), - $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 ) -* - J = J + FJB - GO TO 30 - END IF - ELSE - J = NFXD + 1 - END IF -* -* Use unblocked code to factor the last or only block. -* -* - IF( J.LE.MINMN ) - $ CALL DLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), - $ TAU( J ), WORK( J ), WORK( N+J ), - $ WORK( 2*N+1 ) ) -* - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DGEQP3 -* - END - SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGEQR2 computes a QR factorization of a real m by n matrix A: -* A = Q * R. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix A. -* On exit, the elements on and above the diagonal of the array -* contain the min(m,n) by n upper trapezoidal matrix R (R is -* upper triangular if m >= n); the elements below the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of elementary reflectors (see Further Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(1) H(2) . . . H(k), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v**T -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, K - DOUBLE PRECISION AII -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQR2', -INFO ) - RETURN - END IF -* - K = MIN( M, N ) -* - DO 10 I = 1, K -* -* Generate elementary reflector H(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAU( I ) ) - IF( I.LT.N ) THEN -* -* Apply H(i) to A(i:m,i+1:n) from the left -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = AII - END IF - 10 CONTINUE - RETURN -* -* End of DGEQR2 -* - END - SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGEQRF computes a QR factorization of a real M-by-N matrix A: -* A = Q * R. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix A. -* On exit, the elements on and above the diagonal of the array -* contain the min(M,N)-by-N upper trapezoidal matrix R (R is -* upper triangular if m >= n); the elements below the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of min(m,n) elementary reflectors (see Further -* Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension -* (MAX(1,LWORK)) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is -* the optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(1) H(2) . . . H(k), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v**T -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQRF', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, - $ -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code initially -* - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -* -* Compute the QR factorization of the current block -* A(i:m,i:i+ib-1) -* - CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H**T to A(i:m,i+ib:n) from the left -* - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF - 10 CONTINUE - ELSE - I = 1 - END IF -* -* Use unblocked code to factor the last or only block. -* - IF( I.LE.K ) - $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* - WORK( 1 ) = IWS - RETURN -* -* End of DGEQRF -* - END - SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETF2 computes an LU factorization of a general m-by-n matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, U(k,k) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION SFMIN - INTEGER I, J, JP -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - INTEGER IDAMAX - EXTERNAL DLAMCH, IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DGER, DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Compute machine safe minimum -* - SFMIN = DLAMCH('S') -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP - IF( A( JP, J ).NE.ZERO ) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* Compute elements J+1:M of J-th column. -* - IF( J.LT.M ) THEN - IF( ABS(A( J, J )) .GE. SFMIN ) THEN - CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) - ELSE - DO 20 I = 1, M-J - A( J+I, J ) = A( J+I, J ) / A( J, J ) - 20 CONTINUE - END IF - END IF -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, - $ A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of DGETF2 -* - END - SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETRF computes an LU factorization of a general M-by-N matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL DGETF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGETRF -* - END - SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGETRS solves a system of linear equations -* A * X = B or A**T * X = B -* with a general N-by-N matrix A using the LU factorization computed -* by DGETRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A**T* X = B (Transpose) -* = 'C': A**T* X = B (Conjugate transpose = Transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The factors L and U from the factorization A = P*L*U -* as computed by DGETRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from DGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLASWP, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( NOTRAN ) THEN -* -* Solve A * X = B. -* -* Apply row interchanges to the right hand sides. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A**T * X = B. -* -* Solve U**T *X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve L**T *X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of DGETRS -* - END - DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. -* -* Purpose -* ======= -* -* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary -* overflow. -* -* Arguments -* ========= -* -* X (input) DOUBLE PRECISION -* Y (input) DOUBLE PRECISION -* X and Y specify the values x and y. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION W, XABS, YABS, Z -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - XABS = ABS( X ) - YABS = ABS( Y ) - W = MAX( XABS, YABS ) - Z = MIN( XABS, YABS ) - IF( Z.EQ.ZERO ) THEN - DLAPY2 = W - ELSE - DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) - END IF - RETURN -* -* End of DLAPY2 -* - END - SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, - $ WORK ) -* -* -- LAPACK auxiliary routine (version 3.7.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -* -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER LDA, M, N, OFFSET -* .. -* .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), - $ WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, ITEMP, J, MN, OFFPI, PVT - DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, DSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DNRM2 - EXTERNAL IDAMAX, DLAMCH, DNRM2 -* .. -* .. Executable Statements .. -* - MN = MIN( M-OFFSET, N ) - TOL3Z = SQRT(DLAMCH('EPSILON')) -* -* Compute factorization. -* - DO 20 I = 1, MN -* - OFFPI = OFFSET + I -* -* Determine ith pivot column and swap if necessary. -* - PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 ) -* - IF( PVT.NE.I ) THEN - CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) - ITEMP = JPVT( PVT ) - JPVT( PVT ) = JPVT( I ) - JPVT( I ) = ITEMP - VN1( PVT ) = VN1( I ) - VN2( PVT ) = VN2( I ) - END IF -* -* Generate elementary reflector H(i). -* - IF( OFFPI.LT.M ) THEN - CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, - $ TAU( I ) ) - ELSE - CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) - END IF -* - IF( I.LT.N ) THEN -* -* Apply H(i)**T to A(offset+i:m,i+1:n) from the left. -* - AII = A( OFFPI, I ) - A( OFFPI, I ) = ONE - CALL DLARF( 'LEFT', M-OFFPI+1, N-I, A( OFFPI, I ), 1, - $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) - A( OFFPI, I ) = AII - END IF -* -* Update partial column norms. -* - DO 10 J = I + 1, N - IF( VN1( J ).NE.ZERO ) THEN -* -* NOTE: The following 4 lines follow from the analysis in -* Lapack Working Note 176. -* - TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 - IF( TEMP2 .LE. TOL3Z ) THEN - IF( OFFPI.LT.M ) THEN - VN1( J ) = DNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) - VN2( J ) = VN1( J ) - ELSE - VN1( J ) = ZERO - VN2( J ) = ZERO - END IF - ELSE - VN1( J ) = VN1( J )*SQRT( TEMP ) - END IF - END IF - 10 CONTINUE -* - 20 CONTINUE -* - RETURN -* -* End of DLAQP2 -* - END - SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, - $ VN2, AUXV, F, LDF ) -* -* -- LAPACK auxiliary routine (version 3.7.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -* -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER KB, LDA, LDF, M, N, NB, OFFSET -* .. -* .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), - $ VN1( * ), VN2( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK - DOUBLE PRECISION AKK, TEMP, TEMP2, TOL3Z -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, NINT, SQRT -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DNRM2 - EXTERNAL IDAMAX, DLAMCH, DNRM2 -* .. -* .. Executable Statements .. -* - LASTRK = MIN( M, N+OFFSET ) - LSTICC = 0 - K = 0 - TOL3Z = SQRT(DLAMCH('EPSILON')) -* -* Beginning of while loop. -* - 10 CONTINUE - IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN - K = K + 1 - RK = OFFSET + K -* -* Determine ith pivot column and swap if necessary -* - PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) - IF( PVT.NE.K ) THEN - CALL DSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 ) - CALL DSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF ) - ITEMP = JPVT( PVT ) - JPVT( PVT ) = JPVT( K ) - JPVT( K ) = ITEMP - VN1( PVT ) = VN1( K ) - VN2( PVT ) = VN2( K ) - END IF -* -* Apply previous Householder reflectors to column K: -* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**T. -* - IF( K.GT.1 ) THEN - CALL DGEMV( 'NO TRANSPOSE', M-RK+1, K-1, -ONE, A( RK, 1 ), - $ LDA, F( K, 1 ), LDF, ONE, A( RK, K ), 1 ) - END IF -* -* Generate elementary reflector H(k). -* - IF( RK.LT.M ) THEN - CALL DLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) - ELSE - CALL DLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) - END IF -* - AKK = A( RK, K ) - A( RK, K ) = ONE -* -* Compute Kth column of F: -* -* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**T*A(RK:M,K). -* - IF( K.LT.N ) THEN - CALL DGEMV( 'TRANSPOSE', M-RK+1, N-K, TAU( K ), - $ A( RK, K+1 ), LDA, A( RK, K ), 1, ZERO, - $ F( K+1, K ), 1 ) - END IF -* -* Padding F(1:K,K) with zeros. -* - DO 20 J = 1, K - F( J, K ) = ZERO - 20 CONTINUE -* -* Incremental updating of F: -* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**T -* *A(RK:M,K). -* - IF( K.GT.1 ) THEN - CALL DGEMV( 'TRANSPOSE', M-RK+1, K-1, -TAU( K ), A( RK, 1 ), - $ LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 ) -* - CALL DGEMV( 'NO TRANSPOSE', N, K-1, ONE, F( 1, 1 ), LDF, - $ AUXV( 1 ), 1, ONE, F( 1, K ), 1 ) - END IF -* -* Update the current row of A: -* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**T. -* - IF( K.LT.N ) THEN - CALL DGEMV( 'NO TRANSPOSE', N-K, K, -ONE, F( K+1, 1 ), LDF, - $ A( RK, 1 ), LDA, ONE, A( RK, K+1 ), LDA ) - END IF -* -* Update partial column norms. -* - IF( RK.LT.LASTRK ) THEN - DO 30 J = K + 1, N - IF( VN1( J ).NE.ZERO ) THEN -* -* NOTE: The following 4 lines follow from the analysis -* in -* Lapack Working Note 176. -* - TEMP = ABS( A( RK, J ) ) / VN1( J ) - TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) - TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 - IF( TEMP2 .LE. TOL3Z ) THEN - VN2( J ) = DBLE( LSTICC ) - LSTICC = J - ELSE - VN1( J ) = VN1( J )*SQRT( TEMP ) - END IF - END IF - 30 CONTINUE - END IF -* - A( RK, K ) = AKK -* -* End of while loop. -* - GO TO 10 - END IF - KB = K - RK = OFFSET + KB -* -* Apply the block reflector to the rest of the matrix: -* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - -* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**T. -* - IF( KB.LT.MIN( N, M-OFFSET ) ) THEN - CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M-RK, N-KB, KB, -ONE, - $ A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, - $ A( RK+1, KB+1 ), LDA ) - END IF -* -* Recomputation of difficult columns. -* - 40 CONTINUE - IF( LSTICC.GT.0 ) THEN - ITEMP = NINT( VN2( LSTICC ) ) - VN1( LSTICC ) = DNRM2( M-RK, A( RK+1, LSTICC ), 1 ) -* -* NOTE: The computation of VN1( LSTICC ) relies on the fact that -* SNRM2 does not fail on vectors with norm below the value of -* SQRT(DLAMCH('S')) -* - VN2( LSTICC ) = VN1( LSTICC ) - LSTICC = ITEMP - GO TO 40 - END IF -* - RETURN -* -* End of DLAQPS -* - END - SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER SIDE - INTEGER INCV, LDC, M, N - DOUBLE PRECISION TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLARF applies a real elementary reflector H to a real m by n matrix -* C, from either the left or the right. H is represented in the form -* -* H = I - tau * v * v**T -* -* where tau is a real scalar and v is a real vector. -* -* If tau = 0, then H is taken to be the unit matrix. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': form H * C -* = 'R': form C * H -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* V (input) DOUBLE PRECISION array, dimension -* (1 + (M-1)*abs(INCV)) if SIDE = 'L' -* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' -* The vector v in the representation of H. V is not used if -* TAU = 0. -* -* INCV (input) INTEGER -* The increment between elements of v. INCV <> 0. -* -* TAU (input) DOUBLE PRECISION -* The value tau in the representation of H. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by the matrix H * C if SIDE = 'L', -* or C * H if SIDE = 'R'. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* (N) if SIDE = 'L' -* or (M) if SIDE = 'R' -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL APPLYLEFT - INTEGER I, LASTV, LASTC -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DGER -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILADLR, ILADLC - EXTERNAL LSAME, ILADLR, ILADLC -* .. -* .. Executable Statements .. -* - APPLYLEFT = LSAME( SIDE, 'L' ) - LASTV = 0 - LASTC = 0 - IF( TAU.NE.ZERO ) THEN -! Set up variables for scanning V. LASTV begins pointing to the end -! of V. - IF( APPLYLEFT ) THEN - LASTV = M - ELSE - LASTV = N - END IF - IF( INCV.GT.0 ) THEN - I = 1 + (LASTV-1) * INCV - ELSE - I = 1 - END IF -! Look for the last non-zero row in V. - DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) - LASTV = LASTV - 1 - I = I - INCV - END DO - IF( APPLYLEFT ) THEN -! Scan for the last non-zero column in C(1:lastv,:). - LASTC = ILADLC(LASTV, N, C, LDC) - ELSE -! Scan for the last non-zero row in C(:,1:lastv). - LASTC = ILADLR(M, LASTV, C, LDC) - END IF - END IF -! Note that lastc.eq.0 renders the BLAS operations null; no special -! case is needed at this level. - IF( APPLYLEFT ) THEN -* -* Form H * C -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) -* - CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, - $ ZERO, WORK, 1 ) -* -* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * -* w(1:lastc,1)**T -* - CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) - END IF - ELSE -* -* Form C * H -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) -* - CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, - $ V, INCV, ZERO, WORK, 1 ) -* -* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * -* v(1:lastv,1)**T -* - CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) - END IF - END IF - RETURN -* -* End of DLARF -* - END - SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, - $ T, LDT, C, LDC, WORK, LDWORK ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, SIDE, STOREV, TRANS - INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), - $ WORK( LDWORK, * ) -* .. -* -* Purpose -* ======= -* -* DLARFB applies a real block reflector H or its transpose H**T to a -* real m by n matrix C, from either the left or the right. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply H or H**T from the Left -* = 'R': apply H or H**T from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply H (No transpose) -* = 'T': apply H**T (Transpose) -* -* DIRECT (input) CHARACTER*1 -* Indicates how H is formed from a product of elementary -* reflectors -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Indicates how the vectors which define the elementary -* reflectors are stored: -* = 'C': Columnwise -* = 'R': Rowwise -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* K (input) INTEGER -* The order of the matrix T (= the number of elementary -* reflectors whose product defines the block reflector). -* -* V (input) DOUBLE PRECISION array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,M) if STOREV = 'R' and SIDE = 'L' -* (LDV,N) if STOREV = 'R' and SIDE = 'R' -* The matrix V. See Further Details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); -* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); -* if STOREV = 'R', LDV >= K. -* -* T (input) DOUBLE PRECISION array, dimension (LDT,K) -* The triangular k by k matrix T in the representation of the -* block reflector. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) -* -* LDWORK (input) INTEGER -* The leading dimension of the array WORK. -* If SIDE = 'L', LDWORK >= max(1,N); -* if SIDE = 'R', LDWORK >= max(1,M). -* -* Further Details -* =============== -* -* The shape of the matrix V and the storage of the vectors which define -* the H(i) is best illustrated by the following example with n = 5 and -* k = 3. The elements equal to 1 are not stored; the corresponding -* array elements are modified but restored on exit. The rest of the -* array is not used. -* -* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -* -* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -* ( v1 1 ) ( 1 v2 v2 v2 ) -* ( v1 v2 1 ) ( 1 v3 v3 ) -* ( v1 v2 v3 ) -* ( v1 v2 v3 ) -* -* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -* -* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -* ( v1 v2 v3 ) ( v2 v2 v2 1 ) -* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -* ( 1 v3 ) -* ( 1 ) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - CHARACTER TRANST - INTEGER I, J, LASTV, LASTC -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILADLR, ILADLC - EXTERNAL LSAME, ILADLR, ILADLC -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DTRMM -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( LSAME( TRANS, 'N' ) ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* - IF( LSAME( STOREV, 'C' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 ) (first K rows) -* ( V2 ) -* where V1 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in -* WORK) -* -* W := C1**T -* - DO 10 J = 1, K - CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 10 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2**T *V2 -* - CALL DGEMM( 'Transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**T -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - V2 * W**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**T -* - DO 30 J = 1, K - DO 20 I = 1, LASTC - C( J, I ) = C( J, I ) - WORK( I, J ) - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C1 -* - DO 40 J = 1, K - CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) - 40 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2 * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**T -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - W * V2**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 60 J = 1, K - DO 50 I = 1, LASTC - C( I, J ) = C( I, J ) - WORK( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - ELSE -* -* Let V = ( V1 ) -* ( V2 ) (last K rows) -* where V2 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in -* WORK) -* -* W := C2**T -* - DO 70 J = 1, K - CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - 70 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1**T*V1 -* - CALL DGEMM( 'Transpose', 'No transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**T -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - V1 * W**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) - END IF -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) -* -* C2 := C2 - W**T -* - DO 90 J = 1, K - DO 80 I = 1, LASTC - C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C2 -* - DO 100 J = 1, K - CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 100 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1 * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**T -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - W * V1**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) - END IF -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) -* -* C2 := C2 - W -* - DO 120 J = 1, K - DO 110 I = 1, LASTC - C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) - 110 CONTINUE - 120 CONTINUE - END IF - END IF -* - ELSE IF( LSAME( STOREV, 'R' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 V2 ) (V1: first K columns) -* where V1 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) -* (stored in WORK) -* -* W := C1**T -* - DO 130 J = 1, K - CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 130 CONTINUE -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2**T*V2**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**T * W**T -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - V2**T * W**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, - $ ONE, C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**T -* - DO 150 J = 1, K - DO 140 I = 1, LASTC - C( J, I ) = C( J, I ) - WORK( I, J ) - 140 CONTINUE - 150 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) -* -* W := C1 -* - DO 160 J = 1, K - CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) - 160 CONTINUE -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2 * V2**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - W * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 180 J = 1, K - DO 170 I = 1, LASTC - C( I, J ) = C( I, J ) - WORK( I, J ) - 170 CONTINUE - 180 CONTINUE -* - END IF -* - ELSE -* -* Let V = ( V1 V2 ) (V2: last K columns) -* where V2 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) -* (stored in WORK) -* -* W := C2**T -* - DO 190 J = 1, K - CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - 190 CONTINUE -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1**T * V1**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**T * W**T -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - V1**T * W**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) -* -* C2 := C2 - W**T -* - DO 210 J = 1, K - DO 200 I = 1, LASTC - C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) - 200 CONTINUE - 210 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) -* -* W := C2 -* - DO 220 J = 1, K - CALL DCOPY( LASTC, C( 1, LASTV-K+J ), 1, - $ WORK( 1, J ), 1 ) - 220 CONTINUE -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1 * V1**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - W * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 240 J = 1, K - DO 230 I = 1, LASTC - C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) - 230 CONTINUE - 240 CONTINUE -* - END IF -* - END IF - END IF -* - RETURN -* -* End of DLARFB -* - END - SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION ALPHA, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* Purpose -* ======= -* -* DLARFG generates a real elementary reflector H of order n, such -* that -* -* H * ( alpha ) = ( beta ), H**T * H = I. -* ( x ) ( 0 ) -* -* where alpha and beta are scalars, and x is an (n-1)-element real -* vector. H is represented in the form -* -* H = I - tau * ( 1 ) * ( 1 v**T ) , -* ( v ) -* -* where tau is a real scalar and v is a real (n-1)-element -* vector. -* -* If the elements of x are all zero, then tau = 0 and H is taken to be -* the unit matrix. -* -* Otherwise 1 <= tau <= 2. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the elementary reflector. -* -* ALPHA (input/output) DOUBLE PRECISION -* On entry, the value alpha. -* On exit, it is overwritten with the value beta. -* -* X (input/output) DOUBLE PRECISION array, dimension -* (1+(N-2)*abs(INCX)) -* On entry, the vector x. -* On exit, it is overwritten with the vector v. -* -* INCX (input) INTEGER -* The increment between elements of X. INCX > 0. -* -* TAU (output) DOUBLE PRECISION -* The value tau. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, KNT - DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 - EXTERNAL DLAMCH, DLAPY2, DNRM2 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN -* .. -* .. External Subroutines .. - EXTERNAL DSCAL -* .. -* .. Executable Statements .. -* - IF( N.LE.1 ) THEN - TAU = ZERO - RETURN - END IF -* - XNORM = DNRM2( N-1, X, INCX ) -* - IF( XNORM.EQ.ZERO ) THEN -* -* H = I -* - TAU = ZERO - ELSE -* -* general case -* - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) - KNT = 0 - IF( ABS( BETA ).LT.SAFMIN ) THEN -* -* XNORM, BETA may be inaccurate; scale X and recompute them -* - RSAFMN = ONE / SAFMIN - 10 CONTINUE - KNT = KNT + 1 - CALL DSCAL( N-1, RSAFMN, X, INCX ) - BETA = BETA*RSAFMN - ALPHA = ALPHA*RSAFMN - IF( ABS( BETA ).LT.SAFMIN ) - $ GO TO 10 -* -* New BETA is at most 1, at least SAFMIN -* - XNORM = DNRM2( N-1, X, INCX ) - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - END IF - TAU = ( BETA-ALPHA ) / BETA - CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) -* -* If ALPHA is subnormal, it may lose relative accuracy -* - DO 20 J = 1, KNT - BETA = BETA*SAFMIN - 20 CONTINUE - ALPHA = BETA - END IF -* - RETURN -* -* End of DLARFG -* - END - SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* Purpose -* ======= -* -* DLARFT forms the triangular factor T of a real block reflector H -* of order n, which is defined as a product of k elementary reflectors. -* -* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; -* -* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. -* -* If STOREV = 'C', the vector which defines the elementary reflector -* H(i) is stored in the i-th column of the array V, and -* -* H = I - V * T * V**T -* -* If STOREV = 'R', the vector which defines the elementary reflector -* H(i) is stored in the i-th row of the array V, and -* -* H = I - V**T * T * V -* -* Arguments -* ========= -* -* DIRECT (input) CHARACTER*1 -* Specifies the order in which the elementary reflectors are -* multiplied to form the block reflector: -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Specifies how the vectors which define the elementary -* reflectors are stored (see also Further Details): -* = 'C': columnwise -* = 'R': rowwise -* -* N (input) INTEGER -* The order of the block reflector H. N >= 0. -* -* K (input) INTEGER -* The order of the triangular factor T (= the number of -* elementary reflectors). K >= 1. -* -* V (input/output) DOUBLE PRECISION array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,N) if STOREV = 'R' -* The matrix V. See further details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i). -* -* T (output) DOUBLE PRECISION array, dimension (LDT,K) -* The k by k triangular factor T of the block reflector. -* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is -* lower triangular. The rest of the array is not used. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* Further Details -* =============== -* -* The shape of the matrix V and the storage of the vectors which define -* the H(i) is best illustrated by the following example with n = 5 and -* k = 3. The elements equal to 1 are not stored; the corresponding -* array elements are modified but restored on exit. The rest of the -* array is not used. -* -* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -* -* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -* ( v1 1 ) ( 1 v2 v2 v2 ) -* ( v1 v2 1 ) ( 1 v3 v3 ) -* ( v1 v2 v3 ) -* ( v1 v2 v3 ) -* -* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -* -* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -* ( v1 v2 v3 ) ( v2 v2 v2 1 ) -* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -* ( 1 v3 ) -* ( 1 ) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, PREVLASTV, LASTV - DOUBLE PRECISION VII -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DTRMV -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - PREVLASTV = N - DO 20 I = 1, K - PREVLASTV = MAX( I, PREVLASTV ) - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 10 J = 1, I - T( J, I ) = ZERO - 10 CONTINUE - ELSE -* -* general case -* - VII = V( I, I ) - V( I, I ) = ONE - IF( LSAME( STOREV, 'C' ) ) THEN -! Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) -* - CALL DGEMV( 'Transpose', J-I+1, I-1, -TAU( I ), - $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, - $ T( 1, I ), 1 ) - ELSE -! Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T -* - CALL DGEMV( 'No transpose', I-1, J-I+1, -TAU( I ), - $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, - $ T( 1, I ), 1 ) - END IF - V( I, I ) = VII -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MAX( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - 20 CONTINUE - ELSE - PREVLASTV = 1 - DO 40 I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 30 J = I, K - T( J, I ) = ZERO - 30 CONTINUE - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN - VII = V( N-K+I, I ) - V( N-K+I, I ) = ONE -! Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) := -* - tau(i) * V(j:n-k+i,i+1:k)**T * -* V(j:n-k+i,i) -* - CALL DGEMV( 'Transpose', N-K+I-J+1, K-I, -TAU( I ), - $ V( J, I+1 ), LDV, V( J, I ), 1, ZERO, - $ T( I+1, I ), 1 ) - V( N-K+I, I ) = VII - ELSE - VII = V( I, N-K+I ) - V( I, N-K+I ) = ONE -! Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) := -* - tau(i) * V(i+1:k,j:n-k+i) * -* V(i,j:n-k+i)**T -* - CALL DGEMV( 'No transpose', K-I, N-K+I-J+1, - $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, - $ ZERO, T( I+1, I ), 1 ) - V( I, N-K+I ) = VII - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - T( I, I ) = TAU( I ) - END IF - 40 CONTINUE - END IF - RETURN -* -* End of DLARFT -* - END - SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASWP performs a series of row interchanges on the matrix A. -* One row interchange is initiated for each of rows K1 through K2 of A. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the matrix of column dimension N to which the row -* interchanges will be applied. -* On exit, the permuted matrix. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* -* K1 (input) INTEGER -* The first element of IPIV for which a row interchange will -* be done. -* -* K2 (input) INTEGER -* The last element of IPIV for which a row interchange will -* be done. -* -* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) -* The vector of pivot indices. Only the elements in positions -* K1 through K2 of IPIV are accessed. -* IPIV(K) = L implies rows K and L are to be interchanged. -* -* INCX (input) INTEGER -* The increment between successive values of IPIV. If IPIV -* is negative, the pivots are applied in reverse order. -* -* Further Details -* =============== -* -* Modified by -* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - DOUBLE PRECISION TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) for each of rows K1 through K2. -* - IF( INCX.GT.0 ) THEN - IX0 = K1 - I1 = K1 - I2 = K2 - INC = 1 - ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX - I1 = K2 - I2 = K1 - INC = -1 - ELSE - RETURN - END IF -* - N32 = ( N / 32 )*32 - IF( N32.NE.0 ) THEN - DO 30 J = 1, N32, 32 - IX = IX0 - DO 20 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 10 K = J, J + 31 - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 10 CONTINUE - END IF - IX = IX + INCX - 20 CONTINUE - 30 CONTINUE - END IF - IF( N32.NE.N ) THEN - N32 = N32 + 1 - IX = IX0 - DO 50 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 40 K = N32, N - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 40 CONTINUE - END IF - IX = IX + INCX - 50 CONTINUE - END IF -* - RETURN -* -* End of DLASWP -* - END - SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORM2R overwrites the general real m by n matrix C with -* -* Q * C if SIDE = 'L' and TRANS = 'N', or -* -* Q**T* C if SIDE = 'L' and TRANS = 'T', or -* -* C * Q if SIDE = 'R' and TRANS = 'N', or -* -* C * Q**T if SIDE = 'R' and TRANS = 'T', -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**T from the Left -* = 'R': apply Q or Q**T from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply Q (No transpose) -* = 'T': apply Q**T (Transpose) -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGEQRF in the first k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* (N) if SIDE = 'L', -* (M) if SIDE = 'R' -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORM2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) - $ THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), - $ LDC, WORK ) - A( I, I ) = AII - 10 CONTINUE - RETURN -* -* End of DORM2R -* - END - SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORMQR overwrites the general real M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'T': Q**T * C C * Q**T -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**T from the Left; -* = 'R': apply Q or Q**T from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'T': Transpose, apply Q**T. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGEQRF in the first k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension -* (MAX(1,LWORK)) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW -* .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = MAX( 1, NW )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - ELSE - IWS = NW - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), T, LDT ) - IF( LEFT ) THEN -* -* H or H**T is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H**T is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H**T -* - CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, - $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, - $ WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMQR -* - END - DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) -* -* -- LAPACK auxiliary routine (version 3.3.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* Based on LAPACK DLAMCH but with Fortran 95 query functions -* See: http://www.cs.utk.edu/~luszczek/lapack/lamch.html -* and -* http://www.netlib.org/lapack-dev/lapack-coding/program-style.html#id2537289 -* July 2010 -* -* .. Scalar Arguments .. - CHARACTER CMACH -* .. -* -* Purpose -* ======= -* -* DLAMCH determines double precision machine parameters. -* -* Arguments -* ========= -* -* CMACH (input) CHARACTER*1 -* Specifies the value to be returned by DLAMCH: -* = 'E' or 'e', DLAMCH := eps -* = 'S' or 's , DLAMCH := sfmin -* = 'B' or 'b', DLAMCH := base -* = 'P' or 'p', DLAMCH := eps*base -* = 'N' or 'n', DLAMCH := t -* = 'R' or 'r', DLAMCH := rnd -* = 'M' or 'm', DLAMCH := emin -* = 'U' or 'u', DLAMCH := rmin -* = 'L' or 'l', DLAMCH := emax -* = 'O' or 'o', DLAMCH := rmax -* -* where -* -* eps = relative machine precision -* sfmin = safe minimum, such that 1/sfmin does not overflow -* base = base of the machine -* prec = eps*base -* t = number of (base) digits in the mantissa -* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise -* emin = minimum exponent before (gradual) underflow -* rmin = underflow threshold - base**(emin-1) -* emax = largest exponent before overflow -* rmax = overflow threshold - (base**emax)*(1-eps) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, - $ MINEXPONENT, RADIX, TINY -* .. -* .. Executable Statements .. -* -* -* Assume rounding, not chopping. Always. -* - RND = ONE -* - IF( ONE.EQ.RND ) THEN - EPS = EPSILON(ZERO) * 0.5 - ELSE - EPS = EPSILON(ZERO) - END IF -* - IF( LSAME( CMACH, 'E' ) ) THEN - RMACH = EPS - ELSE IF( LSAME( CMACH, 'S' ) ) THEN - SFMIN = TINY(ZERO) - SMALL = ONE / HUGE(ZERO) - IF( SMALL.GE.SFMIN ) THEN -* -* Use SMALL plus a bit, to avoid the possibility of rounding -* causing overflow when computing 1/sfmin. -* - SFMIN = SMALL*( ONE+EPS ) - END IF - RMACH = SFMIN - ELSE IF( LSAME( CMACH, 'B' ) ) THEN - RMACH = RADIX(ZERO) - ELSE IF( LSAME( CMACH, 'P' ) ) THEN - RMACH = EPS * RADIX(ZERO) - ELSE IF( LSAME( CMACH, 'N' ) ) THEN - RMACH = DIGITS(ZERO) - ELSE IF( LSAME( CMACH, 'R' ) ) THEN - RMACH = RND - ELSE IF( LSAME( CMACH, 'M' ) ) THEN - RMACH = MINEXPONENT(ZERO) - ELSE IF( LSAME( CMACH, 'U' ) ) THEN - RMACH = tiny(zero) - ELSE IF( LSAME( CMACH, 'L' ) ) THEN - RMACH = MAXEXPONENT(ZERO) - ELSE IF( LSAME( CMACH, 'O' ) ) THEN - RMACH = HUGE(ZERO) - ELSE - RMACH = ZERO - END IF -* - DLAMCH = RMACH - RETURN -* -* End of DLAMCH -* - END -************************************************************************ -* - INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER ISPEC - REAL ONE, ZERO -* .. -* -* Purpose -* ======= -* -* IEEECK is called from the ILAENV to verify that Infinity and -* possibly NaN arithmetic is safe (i.e. will not trap). -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies whether to test just for inifinity arithmetic -* or whether to test for infinity and NaN arithmetic. -* = 0: Verify infinity arithmetic only. -* = 1: Verify infinity and NaN arithmetic. -* -* ZERO (input) REAL -* Must contain the value 0.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* ONE (input) REAL -* Must contain the value 1.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* RETURN VALUE: INTEGER -* = 0: Arithmetic failed to produce the correct answers -* = 1: Arithmetic produced the correct answers -* -* ===================================================================== -* -* .. Local Scalars .. - REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, - $ NEGZRO, NEWZRO, POSINF -* .. -* .. Executable Statements .. - IEEECK = 1 -* - POSINF = ONE / ZERO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = -ONE / ZERO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGZRO = ONE / ( NEGINF+ONE ) - IF( NEGZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = ONE / NEGZRO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEWZRO = NEGZRO + ZERO - IF( NEWZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = ONE / NEWZRO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = NEGINF*POSINF - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = POSINF*POSINF - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* -* -* -* -* Return if we were only asked to check infinity arithmetic -* - IF( ISPEC.EQ.0 ) - $ RETURN -* - NAN1 = POSINF + NEGINF -* - NAN2 = POSINF / NEGINF -* - NAN3 = POSINF / POSINF -* - NAN4 = POSINF*ZERO -* - NAN5 = NEGINF*NEGZRO -* - NAN6 = NAN5*ZERO -* - IF( NAN1.EQ.NAN1 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN2.EQ.NAN2 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN3.EQ.NAN3 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN4.EQ.NAN4 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN5.EQ.NAN5 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN6.EQ.NAN6 ) THEN - IEEECK = 0 - RETURN - END IF -* - RETURN - END - INTEGER FUNCTION ILADLC( M, N, A, LDA ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.2.2) -- -* -* -- June 2010 -- -* -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ILADLC scans A for its last non-zero column. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The m by n matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( N.EQ.0 ) THEN - ILADLC = N - ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILADLC = N - ELSE -* Now scan each column from the end, returning with the first -* non-zero. - DO ILADLC = N, 1, -1 - DO I = 1, M - IF( A(I, ILADLC).NE.ZERO ) RETURN - END DO - END DO - END IF - RETURN - END - INTEGER FUNCTION ILADLR( M, N, A, LDA ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ILADLR scans A for its last non-zero row. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The m by n matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( M.EQ.0 ) THEN - ILADLR = M - ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILADLR = M - ELSE -* Scan up each column tracking the last zero row seen. - ILADLR = 0 - DO J = 1, N - I=M - DO WHILE ((A(I,J).NE.ZERO).AND.(I.GE.1)) - I=I-1 - ENDDO - ILADLR = MAX( ILADLR, I ) - END DO - END IF - RETURN - END - INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) -* -* -- LAPACK auxiliary routine (version 3.2.1) -- -* -* -- April 2009 -- -* -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER*( * ) NAME, OPTS - INTEGER ISPEC, N1, N2, N3, N4 -* .. -* -* Purpose -* ======= -* -* ILAENV is called from the LAPACK routines to choose problem-dependent -* parameters for the local environment. See ISPEC for a description of -* the parameters. -* -* ILAENV returns an INTEGER -* if ILAENV >= 0: ILAENV returns the value of the parameter specified -* by ISPEC -* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal -* value. -* -* This version provides a set of parameters which should give good, -* but not optimal, performance on many of the currently available -* computers. Users are encouraged to modify this subroutine to set -* the tuning parameters for their particular machine using the option -* and problem size information in the arguments. -* -* This routine will not function correctly if it is converted to all -* lower case. Converting it to all upper case is allowed. -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies the parameter to be returned as the value of -* ILAENV. -* = 1: the optimal blocksize; if this value is 1, an unblocked -* algorithm will give the best performance. -* = 2: the minimum block size for which the block routine -* should be used; if the usable block size is less than -* this value, an unblocked routine should be used. -* = 3: the crossover point (in a block routine, for N less -* than this value, an unblocked routine should be used) -* = 4: the number of shifts, used in the nonsymmetric -* eigenvalue routines (DEPRECATED) -* = 5: the minimum column dimension for blocking to be used; -* rectangular blocks must have dimension at least k by m, -* where k is given by ILAENV(2,...) and m by ILAENV(5,...) -* = 6: the crossover point for the SVD (when reducing an m by n -* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds -* this value, a QR factorization is used first to reduce -* the matrix to a triangular form.) -* = 7: the number of processors -* = 8: the crossover point for the multishift QR method -* for nonsymmetric eigenvalue problems (DEPRECATED) -* = 9: maximum size of the subproblems at the bottom of the -* computation tree in the divide-and-conquer algorithm -* (used by xGELSD and xGESDD) -* =10: ieee NaN arithmetic can be trusted not to trap -* =11: infinity arithmetic can be trusted not to trap -* 12 <= ISPEC <= 16: -* xHSEQR or one of its subroutines, -* see IPARMQ for detailed explanation -* -* NAME (input) CHARACTER*(*) -* The name of the calling subroutine, in either upper case or -* lower case. -* -* OPTS (input) CHARACTER*(*) -* The character options to the subroutine NAME, concatenated -* into a single character string. For example, UPLO = 'U', -* TRANS = 'T', and DIAG = 'N' for a triangular routine would -* be specified as OPTS = 'UTN'. -* -* N1 (input) INTEGER -* N2 (input) INTEGER -* N3 (input) INTEGER -* N4 (input) INTEGER -* Problem dimensions for the subroutine NAME; these may not all -* be required. -* -* Further Details -* =============== -* -* The following conventions have been used when calling ILAENV from the -* LAPACK routines: -* 1) OPTS is a concatenation of all of the character options to -* subroutine NAME, in the same order that they appear in the -* argument list for NAME, even if they are not used in determining -* the value of the parameter specified by ISPEC. -* 2) The problem dimensions N1, N2, N3, N4 are specified in the order -* that they appear in the argument list for NAME. N1 is used -* first, N2 second, and so on, and unused problem dimensions are -* passed a value of -1. -* 3) The parameter value returned by ILAENV is checked for validity in -* the calling subroutine. For example, ILAENV is used to retrieve -* the optimal blocksize for STRTRI as follows: -* -* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) -* IF( NB.LE.1 ) NB = MAX( 1, N ) -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IC, IZ, NB, NBMIN, NX - LOGICAL CNAME, SNAME - CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 -* .. -* .. Intrinsic Functions .. - INTRINSIC CHAR, ICHAR, INT, MIN, REAL -* .. -* .. External Functions .. - INTEGER IEEECK, IPARMQ - EXTERNAL IEEECK, IPARMQ -* .. -* .. Executable Statements .. -* - GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, - $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC -* -* Invalid value for ISPEC -* - ILAENV = -1 - RETURN -* - 10 CONTINUE -* -* Convert NAME to upper case if the first character is lower case. -* - ILAENV = 1 - SUBNAM = NAME - IC = ICHAR( SUBNAM( 1: 1 ) ) - IZ = ICHAR( 'Z' ) - IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN -* -* ASCII character set -* - IF( IC.GE.97 .AND. IC.LE.122 ) THEN - SUBNAM( 1: 1 ) = CHAR( IC-32 ) - DO 20 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( IC.GE.97 .AND. IC.LE.122 ) - $ SUBNAM( I: I ) = CHAR( IC-32 ) - 20 CONTINUE - END IF -* - ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN -* -* EBCDIC character set -* - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN - SUBNAM( 1: 1 ) = CHAR( IC+64 ) - DO 30 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: - $ I ) = CHAR( IC+64 ) - 30 CONTINUE - END IF -* - ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN -* -* Prime machines: ASCII+128 -* - IF( IC.GE.225 .AND. IC.LE.250 ) THEN - SUBNAM( 1: 1 ) = CHAR( IC-32 ) - DO 40 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( IC.GE.225 .AND. IC.LE.250 ) - $ SUBNAM( I: I ) = CHAR( IC-32 ) - 40 CONTINUE - END IF - END IF -* - C1 = SUBNAM( 1: 1 ) - SNAME = C1.EQ.'S' .OR. C1.EQ.'D' - CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' - IF( .NOT.( CNAME .OR. SNAME ) ) - $ RETURN - C2 = SUBNAM( 2: 3 ) - C3 = SUBNAM( 4: 6 ) - C4 = C3( 2: 3 ) -* - GO TO ( 50, 60, 70 )ISPEC -* - 50 CONTINUE -* -* ISPEC = 1: block size -* -* In these examples, separate code is provided for setting NB for -* real and complex. We assume that NB will take the same value in -* single or double precision. -* - NB = 1 -* - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'PO' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRF' ) THEN - NB = 64 - ELSE IF( C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - END IF - ELSE IF( C2.EQ.'GB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'PB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'TR' ) THEN - IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'LA' ) THEN - IF( C3.EQ.'UUM' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN - IF( C3.EQ.'EBZ' ) THEN - NB = 1 - END IF - END IF - ILAENV = NB - RETURN -* - 60 CONTINUE -* -* ISPEC = 2: minimum block size -* - NBMIN = 2 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. - $ 'QLF' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NBMIN = 8 - ELSE - NBMIN = 8 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - END IF - END IF - ILAENV = NBMIN - RETURN -* - 70 CONTINUE -* -* ISPEC = 3: crossover point -* - NX = 0 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. - $ 'QLF' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NX = 128 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NX = 128 - END IF - END IF - END IF - ILAENV = NX - RETURN -* - 80 CONTINUE -* -* ISPEC = 4: number of shifts (used by xHSEQR) -* - ILAENV = 6 - RETURN -* - 90 CONTINUE -* -* ISPEC = 5: minimum column dimension (not used) -* - ILAENV = 2 - RETURN -* - 100 CONTINUE -* -* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) -* - ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) - RETURN -* - 110 CONTINUE -* -* ISPEC = 7: number of processors (not used) -* - ILAENV = 1 - RETURN -* - 120 CONTINUE -* -* ISPEC = 8: crossover point for multishift (used by xHSEQR) -* - ILAENV = 50 - RETURN -* - 130 CONTINUE -* -* ISPEC = 9: maximum size of the subproblems at the bottom of the -* computation tree in the divide-and-conquer algorithm -* (used by xGELSD and xGESDD) -* - ILAENV = 25 - RETURN -* - 140 CONTINUE -* -* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap -* -* ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 1, 0.0, 1.0 ) - END IF - RETURN -* - 150 CONTINUE -* -* ISPEC = 11: infinity arithmetic can be trusted not to trap -* -* ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 0, 0.0, 1.0 ) - END IF - RETURN -* - 160 CONTINUE -* -* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. -* - ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) - RETURN -* -* End of ILAENV -* - END - INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - INTEGER IHI, ILO, ISPEC, LWORK, N - CHARACTER NAME*( * ), OPTS*( * ) -* -* Purpose -* ======= -* -* This program sets problem and machine dependent parameters -* useful for xHSEQR and its subroutines. It is called whenever -* ILAENV is called with 12 <= ISPEC <= 16 -* -* Arguments -* ========= -* -* ISPEC (input) integer scalar -* ISPEC specifies which tunable parameter IPARMQ should -* return. -* -* ISPEC=12: (INMIN) Matrices of order nmin or less -* are sent directly to xLAHQR, the implicit -* double shift QR algorithm. NMIN must be -* at least 11. -* -* ISPEC=13: (INWIN) Size of the deflation window. -* This is best set greater than or equal to -* the number of simultaneous shifts NS. -* Larger matrices benefit from larger deflation -* windows. -* -* ISPEC=14: (INIBL) Determines when to stop nibbling and -* invest in an (expensive) multi-shift QR sweep. -* If the aggressive early deflation subroutine -* finds LD converged eigenvalues from an order -* NW deflation window and LD.GT.(NW*NIBBLE)/100, -* then the next QR sweep is skipped and early -* deflation is applied immediately to the -* remaining active diagonal block. Setting -* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a -* multi-shift QR sweep whenever early deflation -* finds a converged eigenvalue. Setting -* IPARMQ(ISPEC=14) greater than or equal to 100 -* prevents TTQRE from skipping a multi-shift -* QR sweep. -* -* ISPEC=15: (NSHFTS) The number of simultaneous shifts in -* a multi-shift QR iteration. -* -* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the -* following meanings. -* 0: During the multi-shift QR sweep, -* xLAQR5 does not accumulate reflections and -* does not use matrix-matrix multiply to -* update the far-from-diagonal matrix -* entries. -* 1: During the multi-shift QR sweep, -* xLAQR5 and/or xLAQRaccumulates reflections -* and uses -* matrix-matrix multiply to update the -* far-from-diagonal matrix entries. -* 2: During the multi-shift QR sweep. -* xLAQR5 accumulates reflections and takes -* advantage of 2-by-2 block structure during -* matrix-matrix multiplies. -* (If xTRMM is slower than xGEMM, then -* IPARMQ(ISPEC=16)=1 may be more efficient than -* IPARMQ(ISPEC=16)=2 despite the greater level of -* arithmetic work implied by the latter choice.) -* -* NAME (input) character string -* Name of the calling subroutine -* -* OPTS (input) character string -* This is a concatenation of the string arguments to -* TTQRE. -* -* N (input) integer scalar -* N is the order of the Hessenberg matrix H. -* -* ILO (input) INTEGER -* IHI (input) INTEGER -* It is assumed that H is already upper triangular -* in rows and columns 1:ILO-1 and IHI+1:N. -* -* LWORK (input) integer scalar -* The amount of workspace available. -* -* Further Details -* =============== -* -* Little is known about how best to choose these parameters. -* It is possible to use different values of the parameters -* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. -* -* It is probably best to choose different parameters for -* different matrices and different parameters at different -* times during the iteration, but this has not been -* implemented --- yet. -* -* -* The best choices of most of the parameters depend -* in an ill-understood way on the relative execution -* rate of xLAQR3 and xLAQR5 and on the nature of each -* particular eigenvalue problem. Experiment may be the -* only practical way to determine which choices are most -* effective. -* -* Following is a list of default values supplied by IPARMQ. -* These defaults may be adjusted in order to attain better -* performance in any particular computational environment. -* -* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. -* Default: 75. (Must be at least 11.) -* -* IPARMQ(ISPEC=13) Recommended deflation window size. -* This depends on ILO, IHI and NS, the -* number of simultaneous shifts returned -* by IPARMQ(ISPEC=15). The default for -* (IHI-ILO+1).LE.500 is NS. The default -* for (IHI-ILO+1).GT.500 is 3*NS/2. -* -* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. -* -* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. -* a multi-shift QR iteration. -* -* If IHI-ILO+1 is ... -* -* greater than ...but less ... the -* or equal to ... than default is -* -* 0 30 NS = 2+ -* 30 60 NS = 4+ -* 60 150 NS = 10 -* 150 590 NS = ** -* 590 3000 NS = 64 -* 3000 6000 NS = 128 -* 6000 infinity NS = 256 -* -* (+) By default matrices of this order are -* passed to the implicit double shift routine -* xLAHQR. See IPARMQ(ISPEC=12) above. These -* values of NS are used only in case of a rare -* xLAHQR failure. -* -* (**) The asterisks (**) indicate an ad-hoc -* function increasing from 10 to 64. -* -* IPARMQ(ISPEC=16) Select structured matrix multiply. -* (See ISPEC=16 above for details.) -* Default: 3. -* -* ================================================================ -* .. Parameters .. - INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 - PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, - $ ISHFTS = 15, IACC22 = 16 ) - INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP - PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, - $ NIBBLE = 14, KNWSWP = 500 ) - REAL TWO - PARAMETER ( TWO = 2.0 ) -* .. -* .. Local Scalars .. - INTEGER NH, NS -* .. -* .. Intrinsic Functions .. - INTRINSIC LOG, MAX, MOD, NINT, REAL -* .. -* .. Executable Statements .. - IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. - $ ( ISPEC.EQ.IACC22 ) ) THEN -* -* ==== Set the number simultaneous shifts ==== -* - NH = IHI - ILO + 1 - NS = 2 - IF( NH.GE.30 ) - $ NS = 4 - IF( NH.GE.60 ) - $ NS = 10 - IF( NH.GE.150 ) - $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) - IF( NH.GE.590 ) - $ NS = 64 - IF( NH.GE.3000 ) - $ NS = 128 - IF( NH.GE.6000 ) - $ NS = 256 - NS = MAX( 2, NS-MOD( NS, 2 ) ) - END IF -* - IF( ISPEC.EQ.INMIN ) THEN -* -* -* ===== Matrices of order smaller than NMIN get sent -* . to xLAHQR, the classic double shift algorithm. -* . This must be at least 11. ==== -* - IPARMQ = NMIN -* - ELSE IF( ISPEC.EQ.INIBL ) THEN -* -* ==== INIBL: skip a multi-shift qr iteration and -* . whenever aggressive early deflation finds -* . at least (NIBBLE*(window size)/100) deflations. ==== -* - IPARMQ = NIBBLE -* - ELSE IF( ISPEC.EQ.ISHFTS ) THEN -* -* ==== NSHFTS: The number of simultaneous shifts ===== -* - IPARMQ = NS -* - ELSE IF( ISPEC.EQ.INWIN ) THEN -* -* ==== NW: deflation window size. ==== -* - IF( NH.LE.KNWSWP ) THEN - IPARMQ = NS - ELSE - IPARMQ = 3*NS / 2 - END IF -* - ELSE IF( ISPEC.EQ.IACC22 ) THEN -* -* ==== IACC22: Whether to accumulate reflections -* . before updating the far-from-diagonal elements -* . and whether to use 2-by-2 block structure while -* . doing it. A small amount of work could be saved -* . by making this choice dependent also upon the -* . NH=IHI-ILO+1. -* - IPARMQ = 0 - IF( NS.GE.KACMIN ) - $ IPARMQ = 1 - IF( NS.GE.K22MIN ) - $ IPARMQ = 2 -* - ELSE -* ===== invalid value of ispec ===== - IPARMQ = -1 -* - END IF -* -* ==== End of IPARMQ ==== -* - END - diff --git a/extras/c_binding/dependencies/slatec.f b/extras/c_binding/dependencies/slatec.f deleted file mode 100644 index c652a26..0000000 --- a/extras/c_binding/dependencies/slatec.f +++ /dev/null @@ -1,5023 +0,0 @@ -*DECK DLSEI - SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, - + RNORML, MODE, WS, IP) -C***BEGIN PROLOGUE DLSEI -C***PURPOSE Solve a linearly constrained least squares problem with -C equality and inequality constraints, and optionally compute -C a covariance matrix. -C***LIBRARY SLATEC -C***CATEGORY K1A2A, D9 -C***TYPE DOUBLE PRECISION (LSEI-S, DLSEI-D) -C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, -C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, -C QUADRATIC PROGRAMMING -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Abstract -C -C This subprogram solves a linearly constrained least squares -C problem with both equality and inequality constraints, and, if the -C user requests, obtains a covariance matrix of the solution -C parameters. -C -C Suppose there are given matrices E, A and G of respective -C dimensions ME by N, MA by N and MG by N, and vectors F, B and H of -C respective lengths ME, MA and MG. This subroutine solves the -C linearly constrained least squares problem -C -C EX = F, (E ME by N) (equations to be exactly -C satisfied) -C AX = B, (A MA by N) (equations to be -C approximately satisfied, -C least squares sense) -C GX .GE. H,(G MG by N) (inequality constraints) -C -C The inequalities GX .GE. H mean that every component of the -C product GX must be .GE. the corresponding component of H. -C -C In case the equality constraints cannot be satisfied, a -C generalized inverse solution residual vector length is obtained -C for F-EX. This is the minimal length possible for F-EX. -C -C Any values ME .GE. 0, MA .GE. 0, or MG .GE. 0 are permitted. The -C rank of the matrix E is estimated during the computation. We call -C this value KRANKE. It is an output parameter in IP(1) defined -C below. Using a generalized inverse solution of EX=F, a reduced -C least squares problem with inequality constraints is obtained. -C The tolerances used in these tests for determining the rank -C of E and the rank of the reduced least squares problem are -C given in Sandia Tech. Rept. SAND-78-1290. They can be -C modified by the user if new values are provided in -C the option list of the array PRGOPT(*). -C -C The user must dimension all arrays appearing in the call list.. -C W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2) -C where K=MAX(MA+MG,N). This allows for a solution of a range of -C problems in the given working space. The dimension of WS(*) -C given is a necessary overestimate. Once a particular problem -C has been run, the output parameter IP(3) gives the actual -C dimension required for that problem. -C -C The parameters for DLSEI( ) are -C -C Input.. All TYPE REAL variables are DOUBLE PRECISION -C -C W(*,*),MDW, The array W(*,*) is doubly subscripted with -C ME,MA,MG,N first dimensioning parameter equal to MDW. -C For this discussion let us call M = ME+MA+MG. Then -C MDW must satisfy MDW .GE. M. The condition -C MDW .LT. M is an error. -C -C The array W(*,*) contains the matrices and vectors -C -C (E F) -C (A B) -C (G H) -C -C in rows and columns 1,...,M and 1,...,N+1 -C respectively. -C -C The integers ME, MA, and MG are the -C respective matrix row dimensions -C of E, A and G. Each matrix has N columns. -C -C PRGOPT(*) This real-valued array is the option vector. -C If the user is satisfied with the nominal -C subprogram features set -C -C PRGOPT(1)=1 (or PRGOPT(1)=1.0) -C -C Otherwise PRGOPT(*) is a linked list consisting of -C groups of data of the following form -C -C LINK -C KEY -C DATA SET -C -C The parameters LINK and KEY are each one word. -C The DATA SET can be comprised of several words. -C The number of items depends on the value of KEY. -C The value of LINK points to the first -C entry of the next group of data within -C PRGOPT(*). The exception is when there are -C no more options to change. In that -C case, LINK=1 and the values KEY and DATA SET -C are not referenced. The general layout of -C PRGOPT(*) is as follows. -C -C ...PRGOPT(1) = LINK1 (link to first entry of next group) -C . PRGOPT(2) = KEY1 (key to the option change) -C . PRGOPT(3) = data value (data value for this change) -C . . -C . . -C . . -C ...PRGOPT(LINK1) = LINK2 (link to the first entry of -C . next group) -C . PRGOPT(LINK1+1) = KEY2 (key to the option change) -C . PRGOPT(LINK1+2) = data value -C ... . -C . . -C . . -C ...PRGOPT(LINK) = 1 (no more options to change) -C -C Values of LINK that are nonpositive are errors. -C A value of LINK .GT. NLINK=100000 is also an error. -C This helps prevent using invalid but positive -C values of LINK that will probably extend -C beyond the program limits of PRGOPT(*). -C Unrecognized values of KEY are ignored. The -C order of the options is arbitrary and any number -C of options can be changed with the following -C restriction. To prevent cycling in the -C processing of the option array, a count of the -C number of options changed is maintained. -C Whenever this count exceeds NOPT=1000, an error -C message is printed and the subprogram returns. -C -C Options.. -C -C KEY=1 -C Compute in W(*,*) the N by N -C covariance matrix of the solution variables -C as an output parameter. Nominally the -C covariance matrix will not be computed. -C (This requires no user input.) -C The data set for this option is a single value. -C It must be nonzero when the covariance matrix -C is desired. If it is zero, the covariance -C matrix is not computed. When the covariance matrix -C is computed, the first dimensioning parameter -C of the array W(*,*) must satisfy MDW .GE. MAX(M,N). -C -C KEY=10 -C Suppress scaling of the inverse of the -C normal matrix by the scale factor RNORM**2/ -C MAX(1, no. of degrees of freedom). This option -C only applies when the option for computing the -C covariance matrix (KEY=1) is used. With KEY=1 and -C KEY=10 used as options the unscaled inverse of the -C normal matrix is returned in W(*,*). -C The data set for this option is a single value. -C When it is nonzero no scaling is done. When it is -C zero scaling is done. The nominal case is to do -C scaling so if option (KEY=1) is used alone, the -C matrix will be scaled on output. -C -C KEY=2 -C Scale the nonzero columns of the -C entire data matrix. -C (E) -C (A) -C (G) -C -C to have length one. The data set for this -C option is a single value. It must be -C nonzero if unit length column scaling -C is desired. -C -C KEY=3 -C Scale columns of the entire data matrix -C (E) -C (A) -C (G) -C -C with a user-provided diagonal matrix. -C The data set for this option consists -C of the N diagonal scaling factors, one for -C each matrix column. -C -C KEY=4 -C Change the rank determination tolerance for -C the equality constraint equations from -C the nominal value of SQRT(DRELPR). This quantity can -C be no smaller than DRELPR, the arithmetic- -C storage precision. The quantity DRELPR is the -C largest positive number such that T=1.+DRELPR -C satisfies T .EQ. 1. The quantity used -C here is internally restricted to be at -C least DRELPR. The data set for this option -C is the new tolerance. -C -C KEY=5 -C Change the rank determination tolerance for -C the reduced least squares equations from -C the nominal value of SQRT(DRELPR). This quantity can -C be no smaller than DRELPR, the arithmetic- -C storage precision. The quantity used -C here is internally restricted to be at -C least DRELPR. The data set for this option -C is the new tolerance. -C -C For example, suppose we want to change -C the tolerance for the reduced least squares -C problem, compute the covariance matrix of -C the solution parameters, and provide -C column scaling for the data matrix. For -C these options the dimension of PRGOPT(*) -C must be at least N+9. The Fortran statements -C defining these options would be as follows: -C -C PRGOPT(1)=4 (link to entry 4 in PRGOPT(*)) -C PRGOPT(2)=1 (covariance matrix key) -C PRGOPT(3)=1 (covariance matrix wanted) -C -C PRGOPT(4)=7 (link to entry 7 in PRGOPT(*)) -C PRGOPT(5)=5 (least squares equas. tolerance key) -C PRGOPT(6)=... (new value of the tolerance) -C -C PRGOPT(7)=N+9 (link to entry N+9 in PRGOPT(*)) -C PRGOPT(8)=3 (user-provided column scaling key) -C -C CALL DCOPY (N, D, 1, PRGOPT(9), 1) (Copy the N -C scaling factors from the user array D(*) -C to PRGOPT(9)-PRGOPT(N+8)) -C -C PRGOPT(N+9)=1 (no more options to change) -C -C The contents of PRGOPT(*) are not modified -C by the subprogram. -C The options for WNNLS( ) can also be included -C in this array. The values of KEY recognized -C by WNNLS( ) are 6, 7 and 8. Their functions -C are documented in the usage instructions for -C subroutine WNNLS( ). Normally these options -C do not need to be modified when using DLSEI( ). -C -C IP(1), The amounts of working storage actually -C IP(2) allocated for the working arrays WS(*) and -C IP(*), respectively. These quantities are -C compared with the actual amounts of storage -C needed by DLSEI( ). Insufficient storage -C allocated for either WS(*) or IP(*) is an -C error. This feature was included in DLSEI( ) -C because miscalculating the storage formulas -C for WS(*) and IP(*) might very well lead to -C subtle and hard-to-find execution errors. -C -C The length of WS(*) must be at least -C -C LW = 2*(ME+N)+K+(MG+2)*(N+7) -C -C where K = max(MA+MG,N) -C This test will not be made if IP(1).LE.0. -C -C The length of IP(*) must be at least -C -C LIP = MG+2*N+2 -C This test will not be made if IP(2).LE.0. -C -C Output.. All TYPE REAL variables are DOUBLE PRECISION -C -C X(*),RNORME, The array X(*) contains the solution parameters -C RNORML if the integer output flag MODE = 0 or 1. -C The definition of MODE is given directly below. -C When MODE = 0 or 1, RNORME and RNORML -C respectively contain the residual vector -C Euclidean lengths of F - EX and B - AX. When -C MODE=1 the equality constraint equations EX=F -C are contradictory, so RNORME .NE. 0. The residual -C vector F-EX has minimal Euclidean length. For -C MODE .GE. 2, none of these parameters is defined. -C -C MODE Integer flag that indicates the subprogram -C status after completion. If MODE .GE. 2, no -C solution has been computed. -C -C MODE = -C -C 0 Both equality and inequality constraints -C are compatible and have been satisfied. -C -C 1 Equality constraints are contradictory. -C A generalized inverse solution of EX=F was used -C to minimize the residual vector length F-EX. -C In this sense, the solution is still meaningful. -C -C 2 Inequality constraints are contradictory. -C -C 3 Both equality and inequality constraints -C are contradictory. -C -C The following interpretation of -C MODE=1,2 or 3 must be made. The -C sets consisting of all solutions -C of the equality constraints EX=F -C and all vectors satisfying GX .GE. H -C have no points in common. (In -C particular this does not say that -C each individual set has no points -C at all, although this could be the -C case.) -C -C 4 Usage error occurred. The value -C of MDW is .LT. ME+MA+MG, MDW is -C .LT. N and a covariance matrix is -C requested, or the option vector -C PRGOPT(*) is not properly defined, -C or the lengths of the working arrays -C WS(*) and IP(*), when specified in -C IP(1) and IP(2) respectively, are not -C long enough. -C -C W(*,*) The array W(*,*) contains the N by N symmetric -C covariance matrix of the solution parameters, -C provided this was requested on input with -C the option vector PRGOPT(*) and the output -C flag is returned with MODE = 0 or 1. -C -C IP(*) The integer working array has three entries -C that provide rank and working array length -C information after completion. -C -C IP(1) = rank of equality constraint -C matrix. Define this quantity -C as KRANKE. -C -C IP(2) = rank of reduced least squares -C problem. -C -C IP(3) = the amount of storage in the -C working array WS(*) that was -C actually used by the subprogram. -C The formula given above for the length -C of WS(*) is a necessary overestimate. -C If exactly the same problem matrices -C are used in subsequent executions, -C the declared dimension of WS(*) can -C be reduced to this output value. -C User Designated -C Working Arrays.. -C -C WS(*),IP(*) These are respectively type real -C and type integer working arrays. -C Their required minimal lengths are -C given above. -C -C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Report SAND77-0552, Sandia -C Laboratories, June 1978. -C K. H. Haskell and R. J. Hanson, Selected algorithms for -C the linearly constrained least squares problem - a -C users guide, Report SAND78-1290, Sandia Laboratories, -C August 1979. -C K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Mathematical Programming -C 21 (1981), pp. 98-118. -C R. J. Hanson and K. H. Haskell, Two algorithms for the -C linearly constrained least squares problem, ACM -C Transactions on Mathematical Software, September 1982. -C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, -C DNRM2, DSCAL, DSWAP, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and extensively revised (WRB & RWC) -C 890831 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 900604 DP version created from SP version. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Removed prints and replaced DP --> DOUBLE PRECISION. (THC) -C***END PROLOGUE DLSEI - - INTEGER IP(3), MA, MDW, ME, MG, MODE, N - DOUBLE PRECISION PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*) -C - EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, DNRM2, - * DSCAL, DSWAP - DOUBLE PRECISION D1MACH, DASUM, DDOT, DNRM2 -C - DOUBLE PRECISION DRELPR, ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, - * SN, SNMAX, T, TAU, UJ, UP, VJ, XNORM, XNRME - INTEGER I, IMAX, J, JP1, K, KEY, KRANKE, LAST, LCHK, LINK, M, - * MAPKE1, MDEQC, MEND, MEP1, N1, N2, NEXT, NLINK, NOPT, NP1, - * NTIMES - LOGICAL COV, FIRST -C CHARACTER*8 XERN1, XERN2, XERN3, XERN4 - SAVE FIRST, DRELPR -C - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DLSEI -C -C Set the nominal tolerance used in the code for the equality -C constraint equations. -C - IF (FIRST) DRELPR = D1MACH(4) - FIRST = .FALSE. - TAU = SQRT(DRELPR) -C -C Check that enough storage was allocated in WS(*) and IP(*). -C - MODE = 4 - IF (MIN(N,ME,MA,MG) .LT. 0) THEN -C WRITE (XERN1, '(I8)') N -C WRITE (XERN2, '(I8)') ME -C WRITE (XERN3, '(I8)') MA -C WRITE (XERN4, '(I8)') MG -C CALL XERMSG ('SLATEC', 'LSEI', 'ALL OF THE VARIABLES N, ME,' // -C * ' MA, MG MUST BE .GE. 0$$ENTERED ROUTINE WITH' // -C * '$$N = ' // XERN1 // -C * '$$ME = ' // XERN2 // -C * '$$MA = ' // XERN3 // -C * '$$MG = ' // XERN4, 2, 1) - RETURN - ENDIF -C - IF (IP(1).GT.0) THEN - LCHK = 2*(ME+N) + MAX(MA+MG,N) + (MG+2)*(N+7) - IF (IP(1).LT.LCHK) THEN -C WRITE (XERN1, '(I8)') LCHK -C CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // -C * 'ALLOCATED FOR WS(*), NEED LW = ' // XERN1, 2, 1) - RETURN - ENDIF - ENDIF -C - IF (IP(2).GT.0) THEN - LCHK = MG + 2*N + 2 - IF (IP(2).LT.LCHK) THEN -C WRITE (XERN1, '(I8)') LCHK -C CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // -C * 'ALLOCATED FOR IP(*), NEED LIP = ' // XERN1, 2, 1) - RETURN - ENDIF - ENDIF -C -C Compute number of possible right multiplying Householder -C transformations. -C - M = ME + MA + MG - IF (N.LE.0 .OR. M.LE.0) THEN - MODE = 0 - RNORME = 0 - RNORML = 0 - RETURN - ENDIF -C - IF (MDW.LT.M) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', 'MDW.LT.ME+MA+MG IS AN ERROR', -C + 2, 1) - RETURN - ENDIF -C - NP1 = N + 1 - KRANKE = MIN(ME,N) - N1 = 2*KRANKE + 1 - N2 = N1 + N -C -C Set nominal values. -C -C The nominal column scaling used in the code is -C the identity scaling. -C - CALL DCOPY (N, 1.D0, 0, WS(N1), 1) -C -C No covariance matrix is nominally computed. -C - COV = .FALSE. -C -C Process option vector. -C Define bound for number of options to change. -C - NOPT = 1000 - NTIMES = 0 -C -C Define bound for positive values of LINK. -C - NLINK = 100000 - LAST = 1 - LINK = PRGOPT(1) - IF (LINK.EQ.0 .OR. LINK.GT.NLINK) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', -C + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) - RETURN - ENDIF -C - 100 IF (LINK.GT.1) THEN - NTIMES = NTIMES + 1 - IF (NTIMES.GT.NOPT) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', -C + 'THE LINKS IN THE OPTION VECTOR ARE CYCLING.', 2, 1) - RETURN - ENDIF -C - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.1) THEN - COV = PRGOPT(LAST+2) .NE. 0.D0 - ELSEIF (KEY.EQ.2 .AND. PRGOPT(LAST+2).NE.0.D0) THEN - DO 110 J = 1,N - T = DNRM2(M,W(1,J),1) - IF (T.NE.0.D0) T = 1.D0/T - WS(J+N1-1) = T - 110 CONTINUE - ELSEIF (KEY.EQ.3) THEN - CALL DCOPY (N, PRGOPT(LAST+2), 1, WS(N1), 1) - ELSEIF (KEY.EQ.4) THEN - TAU = MAX(DRELPR,PRGOPT(LAST+2)) - ENDIF -C - NEXT = PRGOPT(LINK) - IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', -C + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) - RETURN - ENDIF -C - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C - DO 120 J = 1,N - CALL DSCAL (M, WS(N1+J-1), W(1,J), 1) - 120 CONTINUE -C - IF (COV .AND. MDW.LT.N) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', -C + 'MDW .LT. N WHEN COV MATRIX NEEDED, IS AN ERROR', 2, 1) - RETURN - ENDIF -C -C Problem definition and option vector OK. -C - MODE = 0 -C -C Compute norm of equality constraint matrix and right side. -C - ENORM = 0.D0 - DO 130 J = 1,N - ENORM = MAX(ENORM,DASUM(ME,W(1,J),1)) - 130 CONTINUE -C - FNORM = DASUM(ME,W(1,NP1),1) - SNMAX = 0.D0 - RNMAX = 0.D0 - DO 150 I = 1,KRANKE -C -C Compute maximum ratio of vector lengths. Partition is at -C column I. -C - DO 140 K = I,ME - SN = DDOT(N-I+1,W(K,I),MDW,W(K,I),MDW) - RN = DDOT(I-1,W(K,1),MDW,W(K,1),MDW) - IF (RN.EQ.0.D0 .AND. SN.GT.SNMAX) THEN - SNMAX = SN - IMAX = K - ELSEIF (K.EQ.I .OR. SN*RNMAX.GT.RN*SNMAX) THEN - SNMAX = SN - RNMAX = RN - IMAX = K - ENDIF - 140 CONTINUE -C -C Interchange rows if necessary. -C - IF (I.NE.IMAX) CALL DSWAP (NP1, W(I,1), MDW, W(IMAX,1), MDW) - IF (SNMAX.GT.RNMAX*TAU**2) THEN -C -C Eliminate elements I+1,...,N in row I. -C - CALL DH12 (1, I, I+1, N, W(I,1), MDW, WS(I), W(I+1,1), MDW, - + 1, M-I) - ELSE - KRANKE = I - 1 - GO TO 160 - ENDIF - 150 CONTINUE -C -C Save diagonal terms of lower trapezoidal matrix. -C - 160 CALL DCOPY (KRANKE, W, MDW+1, WS(KRANKE+1), 1) -C -C Use Householder transformation from left to achieve -C KRANKE by KRANKE upper triangular form. -C - IF (KRANKE.LT.ME) THEN - DO 170 K = KRANKE,1,-1 -C -C Apply transformation to matrix cols. 1,...,K-1. -C - CALL DH12 (1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, - * K-1) -C -C Apply to rt side vector. -C - CALL DH12 (2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, - + 1, 1) - 170 CONTINUE - ENDIF -C -C Solve for variables 1,...,KRANKE in new coordinates. -C - CALL DCOPY (KRANKE, W(1, NP1), 1, X, 1) - DO 180 I = 1,KRANKE - X(I) = (X(I)-DDOT(I-1,W(I,1),MDW,X,1))/W(I,I) - 180 CONTINUE -C -C Compute residuals for reduced problem. -C - MEP1 = ME + 1 - RNORML = 0.D0 - DO 190 I = MEP1,M - W(I,NP1) = W(I,NP1) - DDOT(KRANKE,W(I,1),MDW,X,1) - SN = DDOT(KRANKE,W(I,1),MDW,W(I,1),MDW) - RN = DDOT(N-KRANKE,W(I,KRANKE+1),MDW,W(I,KRANKE+1),MDW) - IF (RN.LE.SN*TAU**2 .AND. KRANKE.LT.N) - * CALL DCOPY (N-KRANKE, 0.D0, 0, W(I,KRANKE+1), MDW) - 190 CONTINUE -C -C Compute equality constraint equations residual length. -C - RNORME = DNRM2(ME-KRANKE,W(KRANKE+1,NP1),1) -C -C Move reduced problem data upward if KRANKE.LT.ME. -C - IF (KRANKE.LT.ME) THEN - DO 200 J = 1,NP1 - CALL DCOPY (M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1) - 200 CONTINUE - ENDIF -C -C Compute solution of reduced problem. -C - CALL DLSI(W(KRANKE+1, KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT, - + X(KRANKE+1), RNORML, MODE, WS(N2), IP(2)) -C -C Test for consistency of equality constraints. -C - IF (ME.GT.0) THEN - MDEQC = 0 - XNRME = DASUM(KRANKE,W(1,NP1),1) - IF (RNORME.GT.TAU*(ENORM*XNRME+FNORM)) MDEQC = 1 - MODE = MODE + MDEQC -C -C Check if solution to equality constraints satisfies inequality -C constraints when there are no degrees of freedom left. -C - IF (KRANKE.EQ.N .AND. MG.GT.0) THEN - XNORM = DASUM(N,X,1) - MAPKE1 = MA + KRANKE + 1 - MEND = MA + KRANKE + MG - DO 210 I = MAPKE1,MEND - SIZE = DASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1)) - IF (W(I,NP1).GT.TAU*SIZE) THEN - MODE = MODE + 2 - GO TO 290 - ENDIF - 210 CONTINUE - ENDIF - ENDIF -C -C Replace diagonal terms of lower trapezoidal matrix. -C - IF (KRANKE.GT.0) THEN - CALL DCOPY (KRANKE, WS(KRANKE+1), 1, W, MDW+1) -C -C Reapply transformation to put solution in original coordinates. -C - DO 220 I = KRANKE,1,-1 - CALL DH12 (2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1) - 220 CONTINUE -C -C Compute covariance matrix of equality constrained problem. -C - IF (COV) THEN - DO 270 J = MIN(KRANKE,N-1),1,-1 - RB = WS(J)*W(J,J) - IF (RB.NE.0.D0) RB = 1.D0/RB - JP1 = J + 1 - DO 230 I = JP1,N - W(I,J) = RB*DDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW) - 230 CONTINUE -C - GAM = 0.5D0*RB*DDOT(N-J,W(JP1,J),1,W(J,JP1),MDW) - CALL DAXPY (N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1) - DO 250 I = JP1,N - DO 240 K = I,N - W(I,K) = W(I,K) + W(J,I)*W(K,J) + W(I,J)*W(J,K) - W(K,I) = W(I,K) - 240 CONTINUE - 250 CONTINUE - UJ = WS(J) - VJ = GAM*UJ - W(J,J) = UJ*VJ + UJ*VJ - DO 260 I = JP1,N - W(J,I) = UJ*W(I,J) + VJ*W(J,I) - 260 CONTINUE - CALL DCOPY (N-J, W(J, JP1), MDW, W(JP1,J), 1) - 270 CONTINUE - ENDIF - ENDIF -C -C Apply the scaling to the covariance matrix. -C - IF (COV) THEN - DO 280 I = 1,N - CALL DSCAL (N, WS(I+N1-1), W(I,1), MDW) - CALL DSCAL (N, WS(I+N1-1), W(1,I), 1) - 280 CONTINUE - ENDIF -C -C Rescale solution vector. -C - 290 IF (MODE.LE.1) THEN - DO 300 J = 1,N - X(J) = X(J)*WS(N1+J-1) - 300 CONTINUE - ENDIF -C - IP(1) = KRANKE - IP(3) = IP(3) + 2*KRANKE + N - RETURN - END -*DECK DLSI - SUBROUTINE DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, - + IP) -C***BEGIN PROLOGUE DLSI -C***SUBSIDIARY -C***PURPOSE Subsidiary to DLSEI -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (LSI-S, DLSI-D) -C***AUTHOR Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to DLSEI. The documentation for -C DLSEI has complete usage instructions. -C -C Solve.. -C AX = B, A MA by N (least squares equations) -C subject to.. -C -C GX.GE.H, G MG by N (inequality constraints) -C -C Input.. -C -C W(*,*) contains (A B) in rows 1,...,MA+MG, cols 1,...,N+1. -C (G H) -C -C MDW,MA,MG,N -C contain (resp) var. dimension of W(*,*), -C and matrix dimensions. -C -C PRGOPT(*), -C Program option vector. -C -C OUTPUT.. -C -C X(*),RNORM -C -C Solution vector(unless MODE=2), length of AX-B. -C -C MODE -C =0 Inequality constraints are compatible. -C =2 Inequality constraints contradictory. -C -C WS(*), -C Working storage of dimension K+N+(MG+2)*(N+7), -C where K=MAX(MA+MG,N). -C IP(MG+2*N+1) -C Integer working storage -C -C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, -C DLPDP, DSCAL, DSWAP -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and extensively revised (WRB & RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900604 DP version created from SP version. (RWC) -C 920422 Changed CALL to DHFTI to include variable MA. (WRB) -C***END PROLOGUE DLSI - - INTEGER IP(*), MA, MDW, MG, MODE, N - DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*) -C - EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, DLPDP, - * DSCAL, DSWAP - DOUBLE PRECISION D1MACH, DASUM, DDOT -C - DOUBLE PRECISION ANORM, DRELPR, FAC, GAM, RB, TAU, TOL, XNORM, - * TMP_NORM(1) - INTEGER I, J, K, KEY, KRANK, KRM1, KRP1, L, LAST, LINK, M, MAP1, - * MDLPDP, MINMAN, N1, N2, N3, NEXT, NP1 - LOGICAL COV, FIRST, SCLCOV -C - SAVE DRELPR, FIRST - DATA FIRST /.TRUE./ -C -C***FIRST EXECUTABLE STATEMENT DLSI -C -C Set the nominal tolerance used in the code. -C - IF (FIRST) DRELPR = D1MACH(4) - FIRST = .FALSE. - TOL = SQRT(DRELPR) -C - MODE = 0 - RNORM = 0.D0 - M = MA + MG - NP1 = N + 1 - KRANK = 0 - IF (N.LE.0 .OR. M.LE.0) GO TO 370 -C -C To process option vector. -C - COV = .FALSE. - SCLCOV = .TRUE. - LAST = 1 - LINK = PRGOPT(1) -C - 100 IF (LINK.GT.1) THEN - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.1) COV = PRGOPT(LAST+2) .NE. 0.D0 - IF (KEY.EQ.10) SCLCOV = PRGOPT(LAST+2) .EQ. 0.D0 - IF (KEY.EQ.5) TOL = MAX(DRELPR,PRGOPT(LAST+2)) - NEXT = PRGOPT(LINK) - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C -C Compute matrix norm of least squares equations. -C - ANORM = 0.D0 - DO 110 J = 1,N - ANORM = MAX(ANORM,DASUM(MA,W(1,J),1)) - 110 CONTINUE -C -C Set tolerance for DHFTI( ) rank test. -C - TAU = TOL*ANORM -C -C Compute Householder orthogonal decomposition of matrix. -C - CALL DCOPY (N, 0.D0, 0, WS, 1) - CALL DCOPY (MA, W(1, NP1), 1, WS, 1) - K = MAX(M,N) - MINMAN = MIN(MA,N) - N1 = K + 1 - N2 = N1 + N - CALL DHFTI (W, MDW, MA, N, WS, MA, 1, TAU, KRANK, TMP_NORM, - + WS(N2), WS(N1), IP) - RNORM = TMP_NORM(1) - FAC = 1.D0 - GAM = MA - KRANK - IF (KRANK.LT.MA .AND. SCLCOV) FAC = RNORM**2/GAM -C -C Reduce to DLPDP and solve. -C - MAP1 = MA + 1 -C -C Compute inequality rt-hand side for DLPDP. -C - IF (MA.LT.M) THEN - IF (MINMAN.GT.0) THEN - DO 120 I = MAP1,M - W(I,NP1) = W(I,NP1) - DDOT(N,W(I,1),MDW,WS,1) - 120 CONTINUE -C -C Apply permutations to col. of inequality constraint matrix. -C - DO 130 I = 1,MINMAN - CALL DSWAP (MG, W(MAP1,I), 1, W(MAP1,IP(I)), 1) - 130 CONTINUE -C -C Apply Householder transformations to constraint matrix. -C - IF (KRANK.GT.0 .AND. KRANK.LT.N) THEN - DO 140 I = KRANK,1,-1 - CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), - + W(MAP1,1), MDW, 1, MG) - 140 CONTINUE - ENDIF -C -C Compute permuted inequality constraint matrix times r-inv. -C - DO 160 I = MAP1,M - DO 150 J = 1,KRANK - W(I,J) = (W(I,J)-DDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J) - 150 CONTINUE - 160 CONTINUE - ENDIF -C -C Solve the reduced problem with DLPDP algorithm, -C the least projected distance problem. -C - CALL DLPDP(W(MAP1,1), MDW, MG, KRANK, N-KRANK, PRGOPT, X, - + XNORM, MDLPDP, WS(N2), IP(N+1)) -C -C Compute solution in original coordinates. -C - IF (MDLPDP.EQ.1) THEN - DO 170 I = KRANK,1,-1 - X(I) = (X(I)-DDOT(KRANK-I,W(I,I+1),MDW,X(I+1),1))/W(I,I) - 170 CONTINUE -C -C Apply Householder transformation to solution vector. -C - IF (KRANK.LT.N) THEN - DO 180 I = 1,KRANK - CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), - + X, 1, 1, 1) - 180 CONTINUE - ENDIF -C -C Repermute variables to their input order. -C - IF (MINMAN.GT.0) THEN - DO 190 I = MINMAN,1,-1 - CALL DSWAP (1, X(I), 1, X(IP(I)), 1) - 190 CONTINUE -C -C Variables are now in original coordinates. -C Add solution of unconstrained problem. -C - DO 200 I = 1,N - X(I) = X(I) + WS(I) - 200 CONTINUE -C -C Compute the residual vector norm. -C - RNORM = SQRT(RNORM**2+XNORM**2) - ENDIF - ELSE - MODE = 2 - ENDIF - ELSE - CALL DCOPY (N, WS, 1, X, 1) - ENDIF -C -C Compute covariance matrix based on the orthogonal decomposition -C from DHFTI( ). -C - IF (.NOT.COV .OR. KRANK.LE.0) GO TO 370 - KRM1 = KRANK - 1 - KRP1 = KRANK + 1 -C -C Copy diagonal terms to working array. -C - CALL DCOPY (KRANK, W, MDW+1, WS(N2), 1) -C -C Reciprocate diagonal terms. -C - DO 210 J = 1,KRANK - W(J,J) = 1.D0/W(J,J) - 210 CONTINUE -C -C Invert the upper triangular QR factor on itself. -C - IF (KRANK.GT.1) THEN - DO 230 I = 1,KRM1 - DO 220 J = I+1,KRANK - W(I,J) = -DDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J) - 220 CONTINUE - 230 CONTINUE - ENDIF -C -C Compute the inverted factor times its transpose. -C - DO 250 I = 1,KRANK - DO 240 J = I,KRANK - W(I,J) = DDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW) - 240 CONTINUE - 250 CONTINUE -C -C Zero out lower trapezoidal part. -C Copy upper triangular to lower triangular part. -C - IF (KRANK.LT.N) THEN - DO 260 J = 1,KRANK - CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) - 260 CONTINUE -C - DO 270 I = KRP1,N - CALL DCOPY (I, 0.D0, 0, W(I,1), MDW) - 270 CONTINUE -C -C Apply right side transformations to lower triangle. -C - N3 = N2 + KRP1 - DO 330 I = 1,KRANK - L = N1 + I - K = N2 + I - RB = WS(L-1)*WS(K-1) -C -C If RB.GE.0.D0, transformation can be regarded as zero. -C - IF (RB.LT.0.D0) THEN - RB = 1.D0/RB -C -C Store unscaled rank one Householder update in work array. -C - CALL DCOPY (N, 0.D0, 0, WS(N3), 1) - L = N1 + I - K = N3 + I - WS(K-1) = WS(L-1) -C - DO 280 J = KRP1,N - WS(N3+J-1) = W(I,J) - 280 CONTINUE -C - DO 290 J = 1,N - WS(J) = RB*(DDOT(J-I,W(J,I),MDW,WS(N3+I-1),1)+ - + DDOT(N-J+1,W(J,J),1,WS(N3+J-1),1)) - 290 CONTINUE -C - L = N3 + I - GAM = 0.5D0*RB*DDOT(N-I+1,WS(L-1),1,WS(I),1) - CALL DAXPY (N-I+1, GAM, WS(L-1), 1, WS(I), 1) - DO 320 J = I,N - DO 300 L = 1,I-1 - W(J,L) = W(J,L) + WS(N3+J-1)*WS(L) - 300 CONTINUE -C - DO 310 L = I,J - W(J,L) = W(J,L) + WS(J)*WS(N3+L-1)+WS(L)*WS(N3+J-1) - 310 CONTINUE - 320 CONTINUE - ENDIF - 330 CONTINUE -C -C Copy lower triangle to upper triangle to symmetrize the -C covariance matrix. -C - DO 340 I = 1,N - CALL DCOPY (I, W(I,1), MDW, W(1,I), 1) - 340 CONTINUE - ENDIF -C -C Repermute rows and columns. -C - DO 350 I = MINMAN,1,-1 - K = IP(I) - IF (I.NE.K) THEN - CALL DSWAP (1, W(I,I), 1, W(K,K), 1) - CALL DSWAP (I-1, W(1,I), 1, W(1,K), 1) - CALL DSWAP (K-I-1, W(I,I+1), MDW, W(I+1,K), 1) - CALL DSWAP (N-K, W(I, K+1), MDW, W(K, K+1), MDW) - ENDIF - 350 CONTINUE -C -C Put in normalized residual sum of squares scale factor -C and symmetrize the resulting covariance matrix. -C - DO 360 J = 1,N - CALL DSCAL (J, FAC, W(1,J), 1) - CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) - 360 CONTINUE -C - 370 IP(1) = KRANK - IP(2) = N + MAX(M,N) + (MG+2)*(N+7) - RETURN - END -*DECK D1MACH - DOUBLE PRECISION FUNCTION D1MACH (I) -C***BEGIN PROLOGUE D1MACH -C***PURPOSE Return floating point machine dependent constants. -C***LIBRARY SLATEC -C***CATEGORY R1 -C***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR Fox, P. A., (Bell Labs) -C Hall, A. D., (Bell Labs) -C Schryer, N. L., (Bell Labs) -C***DESCRIPTION -C -C D1MACH can be used to obtain machine-dependent parameters for the -C local machine environment. It is a function subprogram with one -C (input) argument, and can be referenced as follows: -C -C D = D1MACH(I) -C -C where I=1,...,5. The (output) value of D above is determined by -C the (input) value of I. The results for various values of I are -C discussed below. -C -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 Assume double precision numbers are represented in the T-digit, -C base-B form -C -C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C -C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and -C EMIN .LE. E .LE. EMAX. -C -C The values of B, T, EMIN and EMAX are provided in I1MACH as -C follows: -C I1MACH(10) = B, the base. -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 -C To alter this function for a particular environment, the desired -C set of DATA statements should be activated by removing the C from -C column 1. Also, the values of D1MACH(1) - D1MACH(4) should be -C checked for consistency with the local operating system. -C -C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for -C a portable library, ACM Transactions on Mathematical -C Software 4, 2 (June 1978), pp. 177-188. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 890213 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900618 Added DEC RISC constants. (WRB) -C 900723 Added IBM RS 6000 constants. (WRB) -C 900911 Added SUN 386i constants. (WRB) -C 910710 Added HP 730 constants. (SMR) -C 911114 Added Convex IEEE constants. (WRB) -C 920121 Added SUN -r8 compiler option constants. (WRB) -C 920229 Added Touchstone Delta i860 constants. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920625 Added CONVEX -p8 and -pd8 compiler option constants. -C (BKS, WRB) -C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) -C 010817 Elevated IEEE to highest importance; see next set of -C comments below. (DWL) -C***END PROLOGUE D1MACH -C - - INTEGER SMALL(4) - INTEGER LARGE(4) - INTEGER RIGHT(4) - INTEGER DIVER(4) - INTEGER LOG10(4) -C -C Initial data here correspond to the IEEE standard. The values for -C DMACH(1), DMACH(3) and DMACH(4) are slight upper bounds. The value -C for DMACH(2) is a slight lower bound. The value for DMACH(5) is -C a 20-digit approximation. If one of the sets of initial data below -C is preferred, do the necessary commenting and uncommenting. (DWL) - DOUBLE PRECISION DMACH(5) - DATA DMACH / 2.23D-308, 1.79D+308, 1.111D-16, 2.222D-16, - 1 0.30102999566398119521D0 / - SAVE DMACH -C - 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 AMIGA -C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE APOLLO -C -C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / -C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / -C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / -C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM -C -C DATA SMALL(1) / ZC00800000 / -C DATA SMALL(2) / Z000000000 / -C DATA LARGE(1) / ZDFFFFFFFF / -C DATA LARGE(2) / ZFFFFFFFFF / -C DATA RIGHT(1) / ZCC5800000 / -C DATA RIGHT(2) / Z000000000 / -C DATA DIVER(1) / ZCC6800000 / -C DATA DIVER(2) / Z000000000 / -C DATA LOG10(1) / ZD00E730E7 / -C DATA LOG10(2) / ZC77800DC0 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM -C -C DATA SMALL(1) / O1771000000000000 / -C DATA SMALL(2) / O0000000000000000 / -C DATA LARGE(1) / O0777777777777777 / -C DATA LARGE(2) / O0007777777777777 / -C DATA RIGHT(1) / O1461000000000000 / -C DATA RIGHT(2) / O0000000000000000 / -C DATA DIVER(1) / O1451000000000000 / -C DATA DIVER(2) / O0000000000000000 / -C DATA LOG10(1) / O1157163034761674 / -C DATA LOG10(2) / O0006677466732724 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS -C -C DATA SMALL(1) / O1771000000000000 / -C DATA SMALL(2) / O7770000000000000 / -C DATA LARGE(1) / O0777777777777777 / -C DATA LARGE(2) / O7777777777777777 / -C DATA RIGHT(1) / O1461000000000000 / -C DATA RIGHT(2) / O0000000000000000 / -C DATA DIVER(1) / O1451000000000000 / -C DATA DIVER(2) / O0000000000000000 / -C DATA LOG10(1) / O1157163034761674 / -C DATA LOG10(2) / O0006677466732724 / -C -C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE -C -C DATA SMALL(1) / Z"3001800000000000" / -C DATA SMALL(2) / Z"3001000000000000" / -C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / -C DATA LARGE(2) / Z"4FFE000000000000" / -C DATA RIGHT(1) / Z"3FD2800000000000" / -C DATA RIGHT(2) / Z"3FD2000000000000" / -C DATA DIVER(1) / Z"3FD3800000000000" / -C DATA DIVER(2) / Z"3FD3000000000000" / -C DATA LOG10(1) / Z"3FFF9A209A84FBCF" / -C DATA LOG10(2) / Z"3FFFF7988F8959AC" / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES -C -C DATA SMALL(1) / 00564000000000000000B / -C DATA SMALL(2) / 00000000000000000000B / -C DATA LARGE(1) / 37757777777777777777B / -C DATA LARGE(2) / 37157777777777777777B / -C DATA RIGHT(1) / 15624000000000000000B / -C DATA RIGHT(2) / 00000000000000000000B / -C DATA DIVER(1) / 15634000000000000000B / -C DATA DIVER(2) / 00000000000000000000B / -C DATA LOG10(1) / 17164642023241175717B / -C DATA LOG10(2) / 16367571421742254654B / -C -C MACHINE CONSTANTS FOR THE CELERITY C1260 -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fn OR -pd8 COMPILER OPTION -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CC0000000000000' / -C DATA DMACH(4) / Z'3CD0000000000000' / -C DATA DMACH(5) / Z'3FF34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fi COMPILER OPTION -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -p8 COMPILER OPTION -C -C DATA DMACH(1) / Z'00010000000000000000000000000000' / -C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3F900000000000000000000000000000' / -C DATA DMACH(4) / Z'3F910000000000000000000000000000' / -C DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / -C -C MACHINE CONSTANTS FOR THE CRAY -C -C DATA SMALL(1) / 201354000000000000000B / -C DATA SMALL(2) / 000000000000000000000B / -C DATA LARGE(1) / 577767777777777777777B / -C DATA LARGE(2) / 000007777777777777774B / -C DATA RIGHT(1) / 376434000000000000000B / -C DATA RIGHT(2) / 000000000000000000000B / -C DATA DIVER(1) / 376444000000000000000B / -C DATA DIVER(2) / 000000000000000000000B / -C DATA LOG10(1) / 377774642023241175717B / -C DATA LOG10(2) / 000007571421742254654B / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - -C STATIC DMACH(5) -C -C DATA SMALL / 20K, 3*0 / -C DATA LARGE / 77777K, 3*177777K / -C DATA RIGHT / 31420K, 3*0 / -C DATA DIVER / 32020K, 3*0 / -C DATA LOG10 / 40423K, 42023K, 50237K, 74776K / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING G_FLOAT -C -C DATA DMACH(1) / '0000000000000010'X / -C DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / -C DATA DMACH(3) / '0000000000003CC0'X / -C DATA DMACH(4) / '0000000000003CD0'X / -C DATA DMACH(5) / '79FF509F44133FF3'X / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING IEEE_FORMAT -C -C DATA DMACH(1) / '0010000000000000'X / -C DATA DMACH(2) / '7FEFFFFFFFFFFFFF'X / -C DATA DMACH(3) / '3CA0000000000000'X / -C DATA DMACH(4) / '3CB0000000000000'X / -C DATA DMACH(5) / '3FD34413509F79FF'X / -C -C MACHINE CONSTANTS FOR THE DEC RISC -C -C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ -C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ -C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ -C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ -C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING D_FLOATING -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS -C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS -C -C DATA SMALL(1), SMALL(2) / 128, 0 / -C DATA LARGE(1), LARGE(2) / -32769, -1 / -C DATA RIGHT(1), RIGHT(2) / 9344, 0 / -C DATA DIVER(1), DIVER(2) / 9472, 0 / -C DATA LOG10(1), LOG10(2) / 546979738, -805796613 / -C -C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / -C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING G_FLOATING -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS -C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS -C -C DATA SMALL(1), SMALL(2) / 16, 0 / -C DATA LARGE(1), LARGE(2) / -32769, -1 / -C DATA RIGHT(1), RIGHT(2) / 15552, 0 / -C DATA DIVER(1), DIVER(2) / 15568, 0 / -C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / -C -C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / -C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / -C -C MACHINE CONSTANTS FOR THE ELXSI 6400 -C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) -C -C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / -C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / -C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / -C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / -C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C -C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / -C DATA LARGE(1), LARGE(2) / '37777777, '37777577 / -C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / -C DATA DIVER(1), DIVER(2) / '20000000, '00000334 / -C DATA LOG10(1), LOG10(2) / '23210115, '10237777 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES -C -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 / -C -C MACHINE CONSTANTS FOR THE HP 730 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / -C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / -C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / -C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / -C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA SMALL(1), SMALL(2) / 40000B, 0 / -C DATA SMALL(3), SMALL(4) / 0, 1 / -C DATA LARGE(1), LARGE(2) / 77777B, 177777B / -C DATA LARGE(3), LARGE(4) / 177777B, 177776B / -C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / -C DATA RIGHT(3), RIGHT(4) / 0, 225B / -C DATA DIVER(1), DIVER(2) / 40000B, 0 / -C DATA DIVER(3), DIVER(4) / 0, 227B / -C DATA LOG10(1), LOG10(2) / 46420B, 46502B / -C DATA LOG10(3), LOG10(4) / 76747B, 176377B / -C -C MACHINE CONSTANTS FOR THE HP 9000 -C -C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / -C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / -C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / -C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / -C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND -C THE PERKIN ELMER (INTERDATA) 7/32. -C -C DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / -C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / -C -C MACHINE CONSTANTS FOR THE IBM PC -C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION -C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. -C -C DATA SMALL(1) / 2.23D-308 / -C DATA LARGE(1) / 1.79D+308 / -C DATA RIGHT(1) / 1.11D-16 / -C DATA DIVER(1) / 2.22D-16 / -C DATA LOG10(1) / 0.301029995663981195D0 / -C -C MACHINE CONSTANTS FOR THE IBM RS 6000 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE INTEL i860 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) -C -C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / -C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / -C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / -C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / -C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) -C -C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / -C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / -C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / -C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / -C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -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 / -C -C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / -C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / -C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / -C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / -C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA SMALL(1), SMALL(2) / 128, 0 / -C DATA SMALL(3), SMALL(4) / 0, 0 / -C DATA LARGE(1), LARGE(2) / 32767, -1 / -C DATA LARGE(3), LARGE(4) / -1, -1 / -C DATA RIGHT(1), RIGHT(2) / 9344, 0 / -C DATA RIGHT(3), RIGHT(4) / 0, 0 / -C DATA DIVER(1), DIVER(2) / 9472, 0 / -C DATA DIVER(3), DIVER(4) / 0, 0 / -C DATA LOG10(1), LOG10(2) / 16282, 8346 / -C DATA LOG10(3), LOG10(4) / -31493, -12296 / -C -C DATA SMALL(1), SMALL(2) / O000200, O000000 / -C DATA SMALL(3), SMALL(4) / O000000, O000000 / -C DATA LARGE(1), LARGE(2) / O077777, O177777 / -C DATA LARGE(3), LARGE(4) / O177777, O177777 / -C DATA RIGHT(1), RIGHT(2) / O022200, O000000 / -C DATA RIGHT(3), RIGHT(4) / O000000, O000000 / -C DATA DIVER(1), DIVER(2) / O022400, O000000 / -C DATA DIVER(3), DIVER(4) / O000000, O000000 / -C DATA LOG10(1), LOG10(2) / O037632, O020232 / -C DATA LOG10(3), LOG10(4) / O102373, O147770 / -C -C MACHINE CONSTANTS FOR THE SILICON GRAPHICS -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE SUN -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE SUN -C USING THE -r8 COMPILER OPTION -C -C DATA DMACH(1) / Z'00010000000000000000000000000000' / -C DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / -C DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / -C DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / -C -C MACHINE CONSTANTS FOR THE SUN 386i -C -C DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / -C DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / -C DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' -C DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER -C -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 / -C -C***FIRST EXECUTABLE STATEMENT D1MACH -C IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'D1MACH', -C + 'I OUT OF BOUNDS', 1, 2) -C - D1MACH = DMACH(I) - RETURN -C - END -*DECK I1MACH - INTEGER FUNCTION I1MACH (I) -C***BEGIN PROLOGUE I1MACH -C***PURPOSE Return integer machine dependent constants. -C***LIBRARY SLATEC -C***CATEGORY R1 -C***TYPE INTEGER (I1MACH-I) -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR Fox, P. A., (Bell Labs) -C Hall, A. D., (Bell Labs) -C Schryer, N. L., (Bell Labs) -C***DESCRIPTION -C -C I1MACH can be used to obtain machine-dependent parameters for the -C local machine environment. It is a function subprogram with one -C (input) argument and can be referenced as follows: -C -C K = I1MACH(I) -C -C where I=1,...,16. The (output) value of K above is determined by -C the (input) value of I. The results for various values of I are -C discussed below. -C -C I/O unit numbers: -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 -C Words: -C I1MACH( 5) = the number of bits per integer storage unit. -C I1MACH( 6) = the number of characters per integer storage unit. -C -C Integers: -C assume integers are represented in the S-digit, base-A form -C -C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) -C -C where 0 .LE. X(I) .LT. A for I=0,...,S-1. -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 -C Floating-Point Numbers: -C Assume floating-point numbers are represented in the T-digit, -C base-B form -C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C -C where 0 .LE. X(I) .LT. B for I=1,...,T, -C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. -C I1MACH(10) = B, the base. -C -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 -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 -C To alter this function for a particular environment, the desired -C set of DATA statements should be activated by removing the C from -C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be -C checked for consistency with the local operating system. -C -C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for -C a portable library, ACM Transactions on Mathematical -C Software 4, 2 (June 1978), pp. 177-188. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 891012 Added VAX G-floating constants. (WRB) -C 891012 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900618 Added DEC RISC constants. (WRB) -C 900723 Added IBM RS 6000 constants. (WRB) -C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. -C (RWC) -C 910710 Added HP 730 constants. (SMR) -C 911114 Added Convex IEEE constants. (WRB) -C 920121 Added SUN -r8 compiler option constants. (WRB) -C 920229 Added Touchstone Delta i860 constants. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920625 Added Convex -p8 and -pd8 compiler option constants. -C (BKS, WRB) -C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) -C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler -C options. (DWL, RWC and WRB). -C 010817 Elevated IEEE to highest importance; see next set of -C comments below. (DWL) -C***END PROLOGUE I1MACH -C -C Initial data here correspond to the IEEE standard. If one of the -C sets of initial data below is preferred, do the necessary commenting -C and uncommenting. (DWL) - INTEGER IMACH(16),OUTPUT - DATA IMACH( 1) / 5 / - DATA IMACH( 2) / 6 / - DATA IMACH( 3) / 6 / - DATA IMACH( 4) / 6 / - DATA IMACH( 5) / 32 / - DATA IMACH( 6) / 4 / - DATA IMACH( 7) / 2 / - DATA IMACH( 8) / 31 / - DATA IMACH( 9) / 2147483647 / - DATA IMACH(10) / 2 / - DATA IMACH(11) / 24 / - DATA IMACH(12) / -126 / - DATA IMACH(13) / 127 / - DATA IMACH(14) / 53 / - DATA IMACH(15) / -1022 / - DATA IMACH(16) / 1023 / - SAVE IMACH - EQUIVALENCE (IMACH(4),OUTPUT) -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT COMPILER -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE APOLLO -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 129 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1025 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM -C -C DATA IMACH( 1) / 7 / -C DATA IMACH( 2) / 2 / -C DATA IMACH( 3) / 2 / -C DATA IMACH( 4) / 2 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 33 / -C DATA IMACH( 9) / Z1FFFFFFFF / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -256 / -C DATA IMACH(13) / 255 / -C DATA IMACH(14) / 60 / -C DATA IMACH(15) / -256 / -C DATA IMACH(16) / 255 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM -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) / 48 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 39 / -C DATA IMACH( 9) / O0007777777777777 / -C DATA IMACH(10) / 8 / -C DATA IMACH(11) / 13 / -C DATA IMACH(12) / -50 / -C DATA IMACH(13) / 76 / -C DATA IMACH(14) / 26 / -C DATA IMACH(15) / -50 / -C DATA IMACH(16) / 76 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS -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) / 48 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 39 / -C DATA IMACH( 9) / O0007777777777777 / -C DATA IMACH(10) / 8 / -C DATA IMACH(11) / 13 / -C DATA IMACH(12) / -50 / -C DATA IMACH(13) / 76 / -C DATA IMACH(14) / 26 / -C DATA IMACH(15) / -32754 / -C DATA IMACH(16) / 32780 / -C -C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE -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) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -4095 / -C DATA IMACH(13) / 4094 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -4095 / -C DATA IMACH(16) / 4094 / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6LOUTPUT/ -C DATA IMACH( 5) / 60 / -C DATA IMACH( 6) / 10 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 48 / -C DATA IMACH( 9) / 00007777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -929 / -C DATA IMACH(13) / 1070 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -929 / -C DATA IMACH(16) / 1069 / -C -C MACHINE CONSTANTS FOR THE CELERITY C1260 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 0 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / Z'7FFFFFFF' / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fn COMPILER OPTION -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) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fi COMPILER OPTION -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -p8 COMPILER OPTION -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) / 64 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1023 / -C DATA IMACH(13) / 1023 / -C DATA IMACH(14) / 113 / -C DATA IMACH(15) / -16383 / -C DATA IMACH(16) / 16383 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -pd8 COMPILER OPTION -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) / 64 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1023 / -C DATA IMACH(13) / 1023 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CRAY -C USING THE 46 BIT INTEGER COMPILER OPTION -C -C DATA IMACH( 1) / 100 / -C DATA IMACH( 2) / 101 / -C DATA IMACH( 3) / 102 / -C DATA IMACH( 4) / 101 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 46 / -C DATA IMACH( 9) / 1777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -8189 / -C DATA IMACH(13) / 8190 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -8099 / -C DATA IMACH(16) / 8190 / -C -C MACHINE CONSTANTS FOR THE CRAY -C USING THE 64 BIT INTEGER COMPILER OPTION -C -C DATA IMACH( 1) / 100 / -C DATA IMACH( 2) / 101 / -C DATA IMACH( 3) / 102 / -C DATA IMACH( 4) / 101 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 777777777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -8189 / -C DATA IMACH(13) / 8190 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -8099 / -C DATA IMACH(16) / 8190 / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C -C DATA IMACH( 1) / 11 / -C DATA IMACH( 2) / 12 / -C DATA IMACH( 3) / 8 / -C DATA IMACH( 4) / 10 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING G_FLOAT -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING IEEE_FLOAT -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE DEC RISC -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING D_FLOATING -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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 / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING G_FLOATING -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE ELXSI 6400 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 32 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 24 / -C DATA IMACH( 6) / 3 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 23 / -C DATA IMACH( 9) / 8388607 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 38 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 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) / 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) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 63 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 730 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 4 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 39 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 4 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 55 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 9000 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 7 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 32 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1015 / -C DATA IMACH(16) / 1017 / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND -C THE PERKIN ELMER (INTERDATA) 7/32. -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) / Z7FFFFFFF / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 / -C -C MACHINE CONSTANTS FOR THE IBM PC -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 0 / -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) / -125 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE IBM RS 6000 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 0 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE INTEL i860 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 5 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / "377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 54 / -C DATA IMACH(15) / -101 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 5 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / "377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 62 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGER ARITHMETIC. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGER ARITHMETIC. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -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 / -C -C MACHINE CONSTANTS FOR THE SILICON GRAPHICS -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE SUN -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE SUN -C USING THE -r8 COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / 53 / -C DATA IMACH(12) / -1021 / -C DATA IMACH(13) / 1024 / -C DATA IMACH(14) / 113 / -C DATA IMACH(15) / -16381 / -C DATA IMACH(16) / 16384 / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 1 / -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) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 60 / -C DATA IMACH(15) / -1024 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR -C -C DATA IMACH( 1) / 1 / -C DATA IMACH( 2) / 1 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -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 / -C -C***FIRST EXECUTABLE STATEMENT I1MACH - IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 -C - I1MACH = IMACH(I) - RETURN -C - 10 CONTINUE - WRITE (UNIT = OUTPUT, FMT = 9000) - 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') -C -C CALL FDUMP -C - STOP - END -*DECK DH12 - SUBROUTINE DH12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV, - + NCV) -C***BEGIN PROLOGUE DH12 -C***SUBSIDIARY -C***PURPOSE Subsidiary to DHFTI, DLSEI and DWNNLS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (H12-S, DH12-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C *** DOUBLE PRECISION VERSION OF H12 ****** -C -C C.L.Lawson and R.J.Hanson, Jet Propulsion Laboratory, 1973 Jun 12 -C to appear in 'Solving Least Squares Problems', Prentice-Hall, 1974 -C -C Construction and/or application of a single -C Householder transformation.. Q = I + U*(U**T)/B -C -C MODE = 1 or 2 to select algorithm H1 or H2 . -C LPIVOT is the index of the pivot element. -C L1,M If L1 .LE. M the transformation will be constructed to -C zero elements indexed from L1 through M. If L1 GT. M -C THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. -C U(),IUE,UP On entry to H1 U() contains the pivot vector. -C IUE is the storage increment between elements. -C On exit from H1 U() and UP -C contain quantities defining the vector U of the -C Householder transformation. On entry to H2 U() -C and UP should contain quantities previously computed -C by H1. These will not be modified by H2. -C C() On entry to H1 or H2 C() contains a matrix which will be -C regarded as a set of vectors to which the Householder -C transformation is to be applied. On exit C() contains the -C set of transformed vectors. -C ICE Storage increment between elements of vectors in C(). -C ICV Storage increment between vectors in C(). -C NCV Number of vectors in C() to be transformed. If NCV .LE. 0 -C no operations will be done on C(). -C -C***SEE ALSO DHFTI, DLSEI, DWNNLS -C***ROUTINES CALLED DAXPY, DDOT, DSWAP -C***REVISION HISTORY (YYMMDD) -C 790101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900911 Added DDOT to DOUBLE PRECISION statement. (WRB) -C***END PROLOGUE DH12 - - INTEGER I, I2, I3, I4, ICE, ICV, INCR, IUE, J, KL1, KL2, KLP, - * L1, L1M1, LPIVOT, M, MML1P2, MODE, NCV - DOUBLE PRECISION B, C, CL, CLINV, ONE, UL1M1, SM, U, UP, DDOT - DIMENSION U(IUE,*), C(*) -C BEGIN BLOCK PERMITTING ...EXITS TO 140 -C***FIRST EXECUTABLE STATEMENT DH12 - ONE = 1.0D0 -C -C ...EXIT - IF (0 .GE. LPIVOT .OR. LPIVOT .GE. L1 .OR. L1 .GT. M) GO TO 140 - CL = ABS(U(1,LPIVOT)) - IF (MODE .EQ. 2) GO TO 40 -C ****** CONSTRUCT THE TRANSFORMATION. ****** - DO 10 J = L1, M - CL = MAX(ABS(U(1,J)),CL) - 10 CONTINUE - IF (CL .GT. 0.0D0) GO TO 20 -C .........EXIT - GO TO 140 - 20 CONTINUE - CLINV = ONE/CL - SM = (U(1,LPIVOT)*CLINV)**2 - DO 30 J = L1, M - SM = SM + (U(1,J)*CLINV)**2 - 30 CONTINUE - CL = CL*SQRT(SM) - IF (U(1,LPIVOT) .GT. 0.0D0) CL = -CL - UP = U(1,LPIVOT) - CL - U(1,LPIVOT) = CL - GO TO 50 - 40 CONTINUE -C ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** -C - IF (CL .GT. 0.0D0) GO TO 50 -C ......EXIT - GO TO 140 - 50 CONTINUE -C ...EXIT - IF (NCV .LE. 0) GO TO 140 - B = UP*U(1,LPIVOT) -C B MUST BE NONPOSITIVE HERE. IF B = 0., RETURN. -C - IF (B .LT. 0.0D0) GO TO 60 -C ......EXIT - GO TO 140 - 60 CONTINUE - B = ONE/B - MML1P2 = M - L1 + 2 - IF (MML1P2 .LE. 20) GO TO 80 - L1M1 = L1 - 1 - KL1 = 1 + (L1M1 - 1)*ICE - KL2 = KL1 - KLP = 1 + (LPIVOT - 1)*ICE - UL1M1 = U(1,L1M1) - U(1,L1M1) = UP - IF (LPIVOT .NE. L1M1) CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) - DO 70 J = 1, NCV - SM = DDOT(MML1P2,U(1,L1M1),IUE,C(KL1),ICE) - SM = SM*B - CALL DAXPY(MML1P2,SM,U(1,L1M1),IUE,C(KL1),ICE) - KL1 = KL1 + ICV - 70 CONTINUE - U(1,L1M1) = UL1M1 -C ......EXIT - IF (LPIVOT .EQ. L1M1) GO TO 140 - KL1 = KL2 - CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) - GO TO 130 - 80 CONTINUE - I2 = 1 - ICV + ICE*(LPIVOT - 1) - INCR = ICE*(L1 - LPIVOT) - DO 120 J = 1, NCV - I2 = I2 + ICV - I3 = I2 + INCR - I4 = I3 - SM = C(I2)*UP - DO 90 I = L1, M - SM = SM + C(I3)*U(1,I) - I3 = I3 + ICE - 90 CONTINUE - IF (SM .EQ. 0.0D0) GO TO 110 - SM = SM*B - C(I2) = C(I2) + SM*UP - DO 100 I = L1, M - C(I4) = C(I4) + SM*U(1,I) - I4 = I4 + ICE - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - 130 CONTINUE - 140 CONTINUE - RETURN - END -*DECK DHFTI - SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, - + G, IP) -C***BEGIN PROLOGUE DHFTI -C***PURPOSE Solve a least squares problem for banded matrices using -C sequential accumulation of rows of the data matrix. -C Exactly one right-hand side vector is permitted. -C***LIBRARY SLATEC -C***CATEGORY D9 -C***TYPE DOUBLE PRECISION (HFTI-S, DHFTI-D) -C***KEYWORDS CURVE FITTING, LEAST SQUARES -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DIMENSION A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N) -C -C This subroutine solves a linear least squares problem or a set of -C linear least squares problems having the same matrix but different -C right-side vectors. The problem data consists of an M by N matrix -C A, an M by NB matrix B, and an absolute tolerance parameter TAU -C whose usage is described below. The NB column vectors of B -C represent right-side vectors for NB distinct linear least squares -C problems. -C -C This set of problems can also be written as the matrix least -C squares problem -C -C AX = B, -C -C where X is the N by NB solution matrix. -C -C Note that if B is the M by M identity matrix, then X will be the -C pseudo-inverse of A. -C -C This subroutine first transforms the augmented matrix (A B) to a -C matrix (R C) using premultiplying Householder transformations with -C column interchanges. All subdiagonal elements in the matrix R are -C zero and its diagonal elements satisfy -C -C ABS(R(I,I)).GE.ABS(R(I+1,I+1)), -C -C I = 1,...,L-1, where -C -C L = MIN(M,N). -C -C The subroutine will compute an integer, KRANK, equal to the number -C of diagonal terms of R that exceed TAU in magnitude. Then a -C solution of minimum Euclidean length is computed using the first -C KRANK rows of (R C). -C -C To be specific we suggest that the user consider an easily -C computable matrix norm, such as, the maximum of all column sums of -C magnitudes. -C -C Now if the relative uncertainty of B is EPS, (norm of uncertainty/ -C norm of B), it is suggested that TAU be set approximately equal to -C EPS*(norm of A). -C -C The user must dimension all arrays appearing in the call list.. -C A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N). This -C permits the solution of a range of problems in the same array -C space. -C -C The entire set of parameters for DHFTI are -C -C INPUT.. All TYPE REAL variables are DOUBLE PRECISION -C -C A(*,*),MDA,M,N The array A(*,*) initially contains the M by N -C matrix A of the least squares problem AX = B. -C The first dimensioning parameter of the array -C A(*,*) is MDA, which must satisfy MDA.GE.M -C Either M.GE.N or M.LT.N is permitted. There -C is no restriction on the rank of A. The -C condition MDA.LT.M is considered an error. -C -C B(*),MDB,NB If NB = 0 the subroutine will perform the -C orthogonal decomposition but will make no -C references to the array B(*). If NB.GT.0 -C the array B(*) must initially contain the M by -C NB matrix B of the least squares problem AX = -C B. If NB.GE.2 the array B(*) must be doubly -C subscripted with first dimensioning parameter -C MDB.GE.MAX(M,N). If NB = 1 the array B(*) may -C be either doubly or singly subscripted. In -C the latter case the value of MDB is arbitrary -C but it should be set to some valid integer -C value such as MDB = M. -C -C The condition of NB.GT.1.AND.MDB.LT. MAX(M,N) -C is considered an error. -C -C TAU Absolute tolerance parameter provided by user -C for pseudorank determination. -C -C H(*),G(*),IP(*) Arrays of working space used by DHFTI. -C -C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION -C -C A(*,*) The contents of the array A(*,*) will be -C modified by the subroutine. These contents -C are not generally required by the user. -C -C B(*) On return the array B(*) will contain the N by -C NB solution matrix X. -C -C KRANK Set by the subroutine to indicate the -C pseudorank of A. -C -C RNORM(*) On return, RNORM(J) will contain the Euclidean -C norm of the residual vector for the problem -C defined by the J-th column vector of the array -C B(*,*) for J = 1,...,NB. -C -C H(*),G(*) On return these arrays respectively contain -C elements of the pre- and post-multiplying -C Householder transformations used to compute -C the minimum Euclidean length solution. -C -C IP(*) Array in which the subroutine records indices -C describing the permutation of column vectors. -C The contents of arrays H(*),G(*) and IP(*) -C are not generally required by the user. -C -C***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares -C Problems, Prentice-Hall, Inc., 1974, Chapter 14. -C***ROUTINES CALLED D1MACH, DH12, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891006 Cosmetic changes to prologue. (WRB) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 901005 Replace usage of DDIFF with usage of D1MACH. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DHFTI - - INTEGER I, II, IOPT, IP(*), IP1, J, JB, JJ, K, KP1, KRANK, L, - * LDIAG, LMAX, M, MDA, MDB, N, NB, NERR - DOUBLE PRECISION A, B, D1MACH, DZERO, FACTOR, - * G, H, HMAX, RELEPS, RNORM, SM, SM1, SZERO, TAU, TMP - DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*) - SAVE RELEPS - DATA RELEPS /0.D0/ -C BEGIN BLOCK PERMITTING ...EXITS TO 360 -C***FIRST EXECUTABLE STATEMENT DHFTI - IF (RELEPS.EQ.0.D0) RELEPS = D1MACH(4) - SZERO = 0.0D0 - DZERO = 0.0D0 - FACTOR = 0.001D0 -C - K = 0 - LDIAG = MIN(M,N) - IF (LDIAG .LE. 0) GO TO 350 -C BEGIN BLOCK PERMITTING ...EXITS TO 130 -C BEGIN BLOCK PERMITTING ...EXITS TO 120 - IF (MDA .GE. M) GO TO 10 - NERR = 1 - IOPT = 2 -C CALL XERMSG ('SLATEC', 'DHFTI', -C + 'MDA.LT.M, PROBABLE ERROR.', -C + NERR, IOPT) -C ...............EXIT - GO TO 360 - 10 CONTINUE -C - IF (NB .LE. 1 .OR. MAX(M,N) .LE. MDB) GO TO 20 - NERR = 2 - IOPT = 2 -C CALL XERMSG ('SLATEC', 'DHFTI', -C + 'MDB.LT.MAX(M,N).AND.NB.GT.1. PROBABLE ERROR.', -C + NERR, IOPT) -C ...............EXIT - GO TO 360 - 20 CONTINUE -C - DO 100 J = 1, LDIAG -C BEGIN BLOCK PERMITTING ...EXITS TO 70 - IF (J .EQ. 1) GO TO 40 -C -C UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX -C .. - LMAX = J - DO 30 L = J, N - H(L) = H(L) - A(J-1,L)**2 - IF (H(L) .GT. H(LMAX)) LMAX = L - 30 CONTINUE -C ......EXIT - IF (FACTOR*H(LMAX) .GT. HMAX*RELEPS) GO TO 70 - 40 CONTINUE -C -C COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX -C .. - LMAX = J - DO 60 L = J, N - H(L) = 0.0D0 - DO 50 I = J, M - H(L) = H(L) + A(I,L)**2 - 50 CONTINUE - IF (H(L) .GT. H(LMAX)) LMAX = L - 60 CONTINUE - HMAX = H(LMAX) - 70 CONTINUE -C .. -C LMAX HAS BEEN DETERMINED -C -C DO COLUMN INTERCHANGES IF NEEDED. -C .. - IP(J) = LMAX - IF (IP(J) .EQ. J) GO TO 90 - DO 80 I = 1, M - TMP = A(I,J) - A(I,J) = A(I,LMAX) - A(I,LMAX) = TMP - 80 CONTINUE - H(LMAX) = H(J) - 90 CONTINUE -C -C COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A -C AND B. -C .. - CALL DH12(1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA, - * N-J) - CALL DH12(2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB) - 100 CONTINUE -C -C DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, -C TAU. -C .. - DO 110 J = 1, LDIAG -C ......EXIT - IF (ABS(A(J,J)) .LE. TAU) GO TO 120 - 110 CONTINUE - K = LDIAG -C ......EXIT - GO TO 130 - 120 CONTINUE - K = J - 1 - 130 CONTINUE - KP1 = K + 1 -C -C COMPUTE THE NORMS OF THE RESIDUAL VECTORS. -C - IF (NB .LT. 1) GO TO 170 - DO 160 JB = 1, NB - TMP = SZERO - IF (M .LT. KP1) GO TO 150 - DO 140 I = KP1, M - TMP = TMP + B(I,JB)**2 - 140 CONTINUE - 150 CONTINUE - RNORM(JB) = SQRT(TMP) - 160 CONTINUE - 170 CONTINUE -C SPECIAL FOR PSEUDORANK = 0 - IF (K .GT. 0) GO TO 210 - IF (NB .LT. 1) GO TO 200 - DO 190 JB = 1, NB - DO 180 I = 1, N - B(I,JB) = SZERO - 180 CONTINUE - 190 CONTINUE - 200 CONTINUE - GO TO 340 - 210 CONTINUE -C -C IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER -C DECOMPOSITION OF FIRST K ROWS. -C .. - IF (K .EQ. N) GO TO 230 - DO 220 II = 1, K - I = KP1 - II - CALL DH12(1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1) - 220 CONTINUE - 230 CONTINUE -C -C - IF (NB .LT. 1) GO TO 330 - DO 320 JB = 1, NB -C -C SOLVE THE K BY K TRIANGULAR SYSTEM. -C .. - DO 260 L = 1, K - SM = DZERO - I = KP1 - L - IP1 = I + 1 - IF (K .LT. IP1) GO TO 250 - DO 240 J = IP1, K - SM = SM + A(I,J)*B(J,JB) - 240 CONTINUE - 250 CONTINUE - SM1 = SM - B(I,JB) = (B(I,JB) - SM1)/A(I,I) - 260 CONTINUE -C -C COMPLETE COMPUTATION OF SOLUTION VECTOR. -C .. - IF (K .EQ. N) GO TO 290 - DO 270 J = KP1, N - B(J,JB) = SZERO - 270 CONTINUE - DO 280 I = 1, K - CALL DH12(2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1, - * MDB,1) - 280 CONTINUE - 290 CONTINUE -C -C RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE -C COLUMN INTERCHANGES. -C .. - DO 310 JJ = 1, LDIAG - J = LDIAG + 1 - JJ - IF (IP(J) .EQ. J) GO TO 300 - L = IP(J) - TMP = B(L,JB) - B(L,JB) = B(J,JB) - B(J,JB) = TMP - 300 CONTINUE - 310 CONTINUE - 320 CONTINUE - 330 CONTINUE - 340 CONTINUE - 350 CONTINUE -C .. -C THE SOLUTION VECTORS, X, ARE NOW -C IN THE FIRST N ROWS OF THE ARRAY B(,). -C - KRANK = K - 360 CONTINUE - RETURN - END -*DECK DLPDP - SUBROUTINE DLPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, - + IS) -C***BEGIN PROLOGUE DLPDP -C***SUBSIDIARY -C***PURPOSE Subsidiary to DLSEI -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (LPDP-S, DLPDP-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C **** Double Precision version of LPDP **** -C DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1), -C where N=N1+N2. This is a slight overestimate for WS(*). -C -C Determine an N1-vector W, and -C an N2-vector Z -C which minimizes the Euclidean length of W -C subject to G*W+H*Z .GE. Y. -C This is the least projected distance problem, LPDP. -C The matrices G and H are of respective -C dimensions M by N1 and M by N2. -C -C Called by subprogram DLSI( ). -C -C The matrix -C (G H Y) -C -C occupies rows 1,...,M and cols 1,...,N1+N2+1 of A(*,*). -C -C The solution (W) is returned in X(*). -C (Z) -C -C The value of MODE indicates the status of -C the computation after returning to the user. -C -C MODE=1 The solution was successfully obtained. -C -C MODE=2 The inequalities are inconsistent. -C -C***SEE ALSO DLSEI -C***ROUTINES CALLED DCOPY, DDOT, DNRM2, DSCAL, DWNNLS -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE DLPDP - -C - INTEGER I, IS(*), IW, IX, J, L, M, MDA, MODE, MODEW, N, N1, N2, - * NP1 - DOUBLE PRECISION A(MDA,*), DDOT, DNRM2, FAC, ONE, - * PRGOPT(*), RNORM, SC, WNORM, WS(*), X(*), YNORM, ZERO - SAVE ZERO, ONE, FAC - DATA ZERO,ONE /0.0D0,1.0D0/, FAC /0.1D0/ -C***FIRST EXECUTABLE STATEMENT DLPDP - N = N1 + N2 - MODE = 1 - IF (M .GT. 0) GO TO 20 - IF (N .LE. 0) GO TO 10 - X(1) = ZERO - CALL DCOPY(N,X,0,X,1) - 10 CONTINUE - WNORM = ZERO - GO TO 200 - 20 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 190 - NP1 = N + 1 -C -C SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE. - DO 40 I = 1, M - SC = DNRM2(N,A(I,1),MDA) - IF (SC .EQ. ZERO) GO TO 30 - SC = ONE/SC - CALL DSCAL(NP1,SC,A(I,1),MDA) - 30 CONTINUE - 40 CONTINUE -C -C SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO). - YNORM = DNRM2(M,A(1,NP1),1) - IF (YNORM .EQ. ZERO) GO TO 50 - SC = ONE/YNORM - CALL DSCAL(M,SC,A(1,NP1),1) - 50 CONTINUE -C -C SCALE COLS OF MATRIX H. - J = N1 + 1 - 60 IF (J .GT. N) GO TO 70 - SC = DNRM2(M,A(1,J),1) - IF (SC .NE. ZERO) SC = ONE/SC - CALL DSCAL(M,SC,A(1,J),1) - X(J) = SC - J = J + 1 - GO TO 60 - 70 CONTINUE - IF (N1 .LE. 0) GO TO 130 -C -C COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*). - IW = 0 - DO 80 I = 1, M -C -C MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY. - CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) - IW = IW + N2 -C -C MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY. - CALL DCOPY(N1,A(I,1),MDA,WS(IW+1),1) - IW = IW + N1 -C -C MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY. - WS(IW+1) = A(I,NP1) - IW = IW + 1 - 80 CONTINUE - WS(IW+1) = ZERO - CALL DCOPY(N,WS(IW+1),0,WS(IW+1),1) - IW = IW + N - WS(IW+1) = ONE - IW = IW + 1 -C -C SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0. THE -C MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR -C F = TRANSPOSE OF (0,...,0,1). - IX = IW + 1 - IW = IW + M -C -C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF -C DWNNLS( ). - IS(1) = 0 - IS(2) = 0 - CALL DWNNLS(WS,NP1,N2,NP1-N2,M,0,PRGOPT,WS(IX),RNORM, - * MODEW,IS,WS(IW+1)) -C -C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W. - SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) - IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) - * GO TO 110 - SC = ONE/SC - DO 90 J = 1, N1 - X(J) = SC*DDOT(M,A(1,J),1,WS(IX),1) - 90 CONTINUE -C -C COMPUTE THE VECTOR Q=Y-GW. OVERWRITE Y WITH THIS -C VECTOR. - DO 100 I = 1, M - A(I,NP1) = A(I,NP1) - DDOT(N1,A(I,1),MDA,X,1) - 100 CONTINUE - GO TO 120 - 110 CONTINUE - MODE = 2 -C .........EXIT - GO TO 190 - 120 CONTINUE - 130 CONTINUE - IF (N2 .LE. 0) GO TO 180 -C -C COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*). - IW = 0 - DO 140 I = 1, M - CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) - IW = IW + N2 - WS(IW+1) = A(I,NP1) - IW = IW + 1 - 140 CONTINUE - WS(IW+1) = ZERO - CALL DCOPY(N2,WS(IW+1),0,WS(IW+1),1) - IW = IW + N2 - WS(IW+1) = ONE - IW = IW + 1 - IX = IW + 1 - IW = IW + M -C -C SOLVE RV=S SUBJECT TO V.GE.0. THE MATRIX R =(TRANSPOSE -C OF (H Q)), WHERE Q=Y-GW. THE (N2+1)-VECTOR S =(TRANSPOSE -C OF (0,...,0,1)). -C -C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF -C DWNNLS( ). - IS(1) = 0 - IS(2) = 0 - CALL DWNNLS(WS,N2+1,0,N2+1,M,0,PRGOPT,WS(IX),RNORM,MODEW, - * IS,WS(IW+1)) -C -C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z. - SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) - IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) - * GO TO 160 - SC = ONE/SC - DO 150 J = 1, N2 - L = N1 + J - X(L) = SC*DDOT(M,A(1,L),1,WS(IX),1)*X(L) - 150 CONTINUE - GO TO 170 - 160 CONTINUE - MODE = 2 -C .........EXIT - GO TO 190 - 170 CONTINUE - 180 CONTINUE -C -C ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION. - CALL DSCAL(N,YNORM,X,1) - WNORM = DNRM2(N1,X,1) - 190 CONTINUE - 200 CONTINUE - RETURN - END -*DECK DWNNLS - SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, - + IWORK, WORK) -C***BEGIN PROLOGUE DWNNLS -C***PURPOSE Solve a linearly constrained least squares problem with -C equality constraints and nonnegativity constraints on -C selected variables. -C***LIBRARY SLATEC -C***CATEGORY K1A2A -C***TYPE DOUBLE PRECISION (WNNLS-S, DWNNLS-D) -C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, -C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, -C NONNEGATIVITY CONSTRAINTS, QUADRATIC PROGRAMMING -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Abstract -C -C This subprogram solves a linearly constrained least squares -C problem. Suppose there are given matrices E and A of -C respective dimensions ME by N and MA by N, and vectors F -C and B of respective lengths ME and MA. This subroutine -C solves the problem -C -C EX = F, (equations to be exactly satisfied) -C -C AX = B, (equations to be approximately satisfied, -C in the least squares sense) -C -C subject to components L+1,...,N nonnegative -C -C Any values ME.GE.0, MA.GE.0 and 0.LE. L .LE.N are permitted. -C -C The problem is reposed as problem DWNNLS -C -C (WT*E)X = (WT*F) -C ( A) ( B), (least squares) -C subject to components L+1,...,N nonnegative. -C -C The subprogram chooses the heavy weight (or penalty parameter) WT. -C -C The parameters for DWNNLS are -C -C INPUT.. All TYPE REAL variables are DOUBLE PRECISION -C -C W(*,*),MDW, The array W(*,*) is double subscripted with first -C ME,MA,N,L dimensioning parameter equal to MDW. For this -C discussion let us call M = ME + MA. Then MDW -C must satisfy MDW.GE.M. The condition MDW.LT.M -C is an error. -C -C The array W(*,*) contains the matrices and vectors -C -C (E F) -C (A B) -C -C in rows and columns 1,...,M and 1,...,N+1 -C respectively. Columns 1,...,L correspond to -C unconstrained variables X(1),...,X(L). The -C remaining variables are constrained to be -C nonnegative. The condition L.LT.0 or L.GT.N is -C an error. -C -C PRGOPT(*) This double precision array is the option vector. -C If the user is satisfied with the nominal -C subprogram features set -C -C PRGOPT(1)=1 (or PRGOPT(1)=1.0) -C -C Otherwise PRGOPT(*) is a linked list consisting of -C groups of data of the following form -C -C LINK -C KEY -C DATA SET -C -C The parameters LINK and KEY are each one word. -C The DATA SET can be comprised of several words. -C The number of items depends on the value of KEY. -C The value of LINK points to the first -C entry of the next group of data within -C PRGOPT(*). The exception is when there are -C no more options to change. In that -C case LINK=1 and the values KEY and DATA SET -C are not referenced. The general layout of -C PRGOPT(*) is as follows. -C -C ...PRGOPT(1)=LINK1 (link to first entry of next group) -C . PRGOPT(2)=KEY1 (key to the option change) -C . PRGOPT(3)=DATA VALUE (data value for this change) -C . . -C . . -C . . -C ...PRGOPT(LINK1)=LINK2 (link to the first entry of -C . next group) -C . PRGOPT(LINK1+1)=KEY2 (key to the option change) -C . PRGOPT(LINK1+2)=DATA VALUE -C ... . -C . . -C . . -C ...PRGOPT(LINK)=1 (no more options to change) -C -C Values of LINK that are nonpositive are errors. -C A value of LINK.GT.NLINK=100000 is also an error. -C This helps prevent using invalid but positive -C values of LINK that will probably extend -C beyond the program limits of PRGOPT(*). -C Unrecognized values of KEY are ignored. The -C order of the options is arbitrary and any number -C of options can be changed with the following -C restriction. To prevent cycling in the -C processing of the option array a count of the -C number of options changed is maintained. -C Whenever this count exceeds NOPT=1000 an error -C message is printed and the subprogram returns. -C -C OPTIONS.. -C -C KEY=6 -C Scale the nonzero columns of the -C entire data matrix -C (E) -C (A) -C to have length one. The DATA SET for -C this option is a single value. It must -C be nonzero if unit length column scaling is -C desired. -C -C KEY=7 -C Scale columns of the entire data matrix -C (E) -C (A) -C with a user-provided diagonal matrix. -C The DATA SET for this option consists -C of the N diagonal scaling factors, one for -C each matrix column. -C -C KEY=8 -C Change the rank determination tolerance from -C the nominal value of SQRT(SRELPR). This quantity -C can be no smaller than SRELPR, The arithmetic- -C storage precision. The quantity used -C here is internally restricted to be at -C least SRELPR. The DATA SET for this option -C is the new tolerance. -C -C KEY=9 -C Change the blow-up parameter from the -C nominal value of SQRT(SRELPR). The reciprocal of -C this parameter is used in rejecting solution -C components as too large when a variable is -C first brought into the active set. Too large -C means that the proposed component times the -C reciprocal of the parameter is not less than -C the ratio of the norms of the right-side -C vector and the data matrix. -C This parameter can be no smaller than SRELPR, -C the arithmetic-storage precision. -C -C For example, suppose we want to provide -C a diagonal matrix to scale the problem -C matrix and change the tolerance used for -C determining linear dependence of dropped col -C vectors. For these options the dimensions of -C PRGOPT(*) must be at least N+6. The FORTRAN -C statements defining these options would -C be as follows. -C -C PRGOPT(1)=N+3 (link to entry N+3 in PRGOPT(*)) -C PRGOPT(2)=7 (user-provided scaling key) -C -C CALL DCOPY(N,D,1,PRGOPT(3),1) (copy the N -C scaling factors from a user array called D(*) -C into PRGOPT(3)-PRGOPT(N+2)) -C -C PRGOPT(N+3)=N+6 (link to entry N+6 of PRGOPT(*)) -C PRGOPT(N+4)=8 (linear dependence tolerance key) -C PRGOPT(N+5)=... (new value of the tolerance) -C -C PRGOPT(N+6)=1 (no more options to change) -C -C -C IWORK(1), The amounts of working storage actually allocated -C IWORK(2) for the working arrays WORK(*) and IWORK(*), -C respectively. These quantities are compared with -C the actual amounts of storage needed for DWNNLS( ). -C Insufficient storage allocated for either WORK(*) -C or IWORK(*) is considered an error. This feature -C was included in DWNNLS( ) because miscalculating -C the storage formulas for WORK(*) and IWORK(*) -C might very well lead to subtle and hard-to-find -C execution errors. -C -C The length of WORK(*) must be at least -C -C LW = ME+MA+5*N -C This test will not be made if IWORK(1).LE.0. -C -C The length of IWORK(*) must be at least -C -C LIW = ME+MA+N -C This test will not be made if IWORK(2).LE.0. -C -C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION -C -C X(*) An array dimensioned at least N, which will -C contain the N components of the solution vector -C on output. -C -C RNORM The residual norm of the solution. The value of -C RNORM contains the residual vector length of the -C equality constraints and least squares equations. -C -C MODE The value of MODE indicates the success or failure -C of the subprogram. -C -C MODE = 0 Subprogram completed successfully. -C -C = 1 Max. number of iterations (equal to -C 3*(N-L)) exceeded. Nearly all problems -C should complete in fewer than this -C number of iterations. An approximate -C solution and its corresponding residual -C vector length are in X(*) and RNORM. -C -C = 2 Usage error occurred. The offending -C condition is noted with the error -C processing subprogram, XERMSG( ). -C -C User-designated -C Working arrays.. -C -C WORK(*) A double precision working array of length at least -C M + 5*N. -C -C IWORK(*) An integer-valued working array of length at least -C M+N. -C -C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Report SAND77-0552, Sandia -C Laboratories, June 1978. -C K. H. Haskell and R. J. Hanson, Selected algorithms for -C the linearly constrained least squares problem - a -C users guide, Report SAND78-1290, Sandia Laboratories, -C August 1979. -C K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Mathematical Programming -C 21 (1981), pp. 98-118. -C R. J. Hanson and K. H. Haskell, Two algorithms for the -C linearly constrained least squares problem, ACM -C Transactions on Mathematical Software, September 1982. -C C. L. Lawson and R. J. Hanson, Solving Least Squares -C Problems, Prentice-Hall, Inc., 1974. -C***ROUTINES CALLED DWNLSM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls, change Prologue -C comments to agree with WNNLS. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Removed prints and replaced DP --> DOUBLE PRECISION. (THC) -C***END PROLOGUE DWNNLS - - INTEGER IWORK(*), L, L1, L2, L3, L4, L5, LIW, LW, MA, MDW, ME, - * MODE, N - DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) -C CHARACTER*8 XERN1 -C***FIRST EXECUTABLE STATEMENT DWNNLS - MODE = 0 - IF (MA+ME.LE.0 .OR. N.LE.0) RETURN -C - IF (IWORK(1).GT.0) THEN - LW = ME + MA + 5*N - IF (IWORK(1).LT.LW) THEN -C WRITE (XERN1, '(I8)') LW -C CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // -C * 'ALLOCATED FOR WORK(*), NEED LW = ' // XERN1, 2, 1) - MODE = 2 - RETURN - ENDIF - ENDIF -C - IF (IWORK(2).GT.0) THEN - LIW = ME + MA + N - IF (IWORK(2).LT.LIW) THEN -C WRITE (XERN1, '(I8)') LIW -C CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // -C * 'ALLOCATED FOR IWORK(*), NEED LIW = ' // XERN1, 2, 1) - MODE = 2 - RETURN - ENDIF - ENDIF -C - IF (MDW.LT.ME+MA) THEN -C CALL XERMSG ('SLATEC', 'DWNNLS', -C * 'THE VALUE MDW.LT.ME+MA IS AN ERROR', 1, 1) - MODE = 2 - RETURN - ENDIF -C - IF (L.LT.0 .OR. L.GT.N) THEN -C CALL XERMSG ('SLATEC', 'DWNNLS', -C * 'L.GE.0 .AND. L.LE.N IS REQUIRED', 2, 1) - MODE = 2 - RETURN - ENDIF -C -C THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS -C WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS -C REQUIRED BY THE MAIN SUBROUTINE DWNLSM( ). -C - L1 = N + 1 - L2 = L1 + N - L3 = L2 + ME + MA - L4 = L3 + N - L5 = L4 + N -C - CALL DWNLSM(W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, IWORK, - * IWORK(L1), WORK(1), WORK(L1), WORK(L2), WORK(L3), - * WORK(L4), WORK(L5)) - RETURN - END -*DECK DWNLSM - SUBROUTINE DWNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, - + IPIVOT, ITYPE, WD, H, SCALE, Z, TEMP, D) -C***BEGIN PROLOGUE DWNLSM -C***SUBSIDIARY -C***PURPOSE Subsidiary to DWNNLS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLSM-S, DWNLSM-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to DWNNLS. -C The documentation for DWNNLS has complete usage instructions. -C -C In addition to the parameters discussed in the prologue to -C subroutine DWNNLS, the following work arrays are used in -C subroutine DWNLSM (they are passed through the calling -C sequence from DWNNLS for purposes of variable dimensioning). -C Their contents will in general be of no interest to the user. -C -C Variables of type REAL are DOUBLE PRECISION. -C -C IPIVOT(*) -C An array of length N. Upon completion it contains the -C pivoting information for the cols of W(*,*). -C -C ITYPE(*) -C An array of length M which is used to keep track -C of the classification of the equations. ITYPE(I)=0 -C denotes equation I as an equality constraint. -C ITYPE(I)=1 denotes equation I as a least squares -C equation. -C -C WD(*) -C An array of length N. Upon completion it contains the -C dual solution vector. -C -C H(*) -C An array of length N. Upon completion it contains the -C pivot scalars of the Householder transformations performed -C in the case KRANK.LT.L. -C -C SCALE(*) -C An array of length M which is used by the subroutine -C to store the diagonal matrix of weights. -C These are used to apply the modified Givens -C transformations. -C -C Z(*),TEMP(*) -C Working arrays of length N. -C -C D(*) -C An array of length N that contains the -C column scaling for the matrix (E). -C (A) -C -C***SEE ALSO DWNNLS -C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, -C SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, -C DWNLIT, IDAMAX, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Fixed an error message. (RWC) -C 900604 DP version created from SP version. (RWC) -C 900911 Restriction on value of ALAMDA included. (WRB) -C***END PROLOGUE DWNLSM - - INTEGER IPIVOT(*), ITYPE(*), L, MA, MDW, MME, MODE, N - DOUBLE PRECISION D(*), H(*), PRGOPT(*), RNORM, SCALE(*), TEMP(*), - * W(MDW,*), WD(*), X(*), Z(*) -C - EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, SLATEC_DROTM, - * SLATEC_DROTMG, DSCAL, DSWAP, DWNLIT, IDAMAX, XERMSG - DOUBLE PRECISION D1MACH, DASUM, DNRM2 - INTEGER IDAMAX -C - DOUBLE PRECISION ALAMDA, ALPHA, ALSQ, AMAX, BLOWUP, BNORM, - * DOPE(3), DRELPR, EANORM, FAC, SM, SPARAM(5), T, TAU, WMAX, Z2, - * ZZ - INTEGER I, IDOPE(3), IMAX, ISOL, ITEMP, ITER, ITMAX, IWMAX, J, - * JCON, JP, KEY, KRANK, L1, LAST, LINK, M, ME, NEXT, NIV, NLINK, - * NOPT, NSOLN, NTIMES - LOGICAL DONE, FEASBL, FIRST, HITCON, POS -C - SAVE DRELPR, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DWNLSM -C -C Initialize variables. -C DRELPR is the precision for the particular machine -C being used. This logic avoids resetting it every entry. -C - IF (FIRST) DRELPR = D1MACH(4) - FIRST = .FALSE. -C -C Set the nominal tolerance used in the code. -C - TAU = SQRT(DRELPR) -C - M = MA + MME - ME = MME - MODE = 2 -C -C To process option vector -C - FAC = 1.D-4 -C -C Set the nominal blow up factor used in the code. -C - BLOWUP = TAU -C -C The nominal column scaling used in the code is -C the identity scaling. -C - CALL DCOPY (N, 1.D0, 0, D, 1) -C -C Define bound for number of options to change. -C - NOPT = 1000 -C -C Define bound for positive value of LINK. -C - NLINK = 100000 - NTIMES = 0 - LAST = 1 - LINK = PRGOPT(1) - IF (LINK.LE.0 .OR. LINK.GT.NLINK) THEN -C CALL XERMSG ('SLATEC', 'DWNLSM', -C + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) - RETURN - ENDIF -C - 100 IF (LINK.GT.1) THEN - NTIMES = NTIMES + 1 - IF (NTIMES.GT.NOPT) THEN -C CALL XERMSG ('SLATEC', 'DWNLSM', -C + 'IN DWNNLS, THE LINKS IN THE OPTION VECTOR ARE CYCLING.', -C + 3, 1) - RETURN - ENDIF -C - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.6 .AND. PRGOPT(LAST+2).NE.0.D0) THEN - DO 110 J = 1,N - T = DNRM2(M,W(1,J),1) - IF (T.NE.0.D0) T = 1.D0/T - D(J) = T - 110 CONTINUE - ENDIF -C - IF (KEY.EQ.7) CALL DCOPY (N, PRGOPT(LAST+2), 1, D, 1) - IF (KEY.EQ.8) TAU = MAX(DRELPR,PRGOPT(LAST+2)) - IF (KEY.EQ.9) BLOWUP = MAX(DRELPR,PRGOPT(LAST+2)) -C - NEXT = PRGOPT(LINK) - IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN -C CALL XERMSG ('SLATEC', 'DWNLSM', -C + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) - RETURN - ENDIF -C - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C - DO 120 J = 1,N - CALL DSCAL (M, D(J), W(1,J), 1) - 120 CONTINUE -C -C Process option vector -C - DONE = .FALSE. - ITER = 0 - ITMAX = 3*(N-L) - MODE = 0 - NSOLN = L - L1 = MIN(M,L) -C -C Compute scale factor to apply to equality constraint equations. -C - DO 130 J = 1,N - WD(J) = DASUM(M,W(1,J),1) - 130 CONTINUE -C - IMAX = IDAMAX(N,WD,1) - EANORM = WD(IMAX) - BNORM = DASUM(M,W(1,N+1),1) - ALAMDA = EANORM/(DRELPR*FAC) -C -C On machines, such as the VAXes using D floating, with a very -C limited exponent range for double precision values, the previously -C computed value of ALAMDA may cause an overflow condition. -C Therefore, this code further limits the value of ALAMDA. -C - ALAMDA = MIN(ALAMDA,SQRT(D1MACH(2))) -C -C Define scaling diagonal matrix for modified Givens usage and -C classify equation types. -C - ALSQ = ALAMDA**2 - DO 140 I = 1,M -C -C When equation I is heavily weighted ITYPE(I)=0, -C else ITYPE(I)=1. -C - IF (I.LE.ME) THEN - T = ALSQ - ITEMP = 0 - ELSE - T = 1.D0 - ITEMP = 1 - ENDIF - SCALE(I) = T - ITYPE(I) = ITEMP - 140 CONTINUE -C -C Set the solution vector X(*) to zero and the column interchange -C matrix to the identity. -C - CALL DCOPY (N, 0.D0, 0, X, 1) - DO 150 I = 1,N - IPIVOT(I) = I - 150 CONTINUE -C -C Perform initial triangularization in the submatrix -C corresponding to the unconstrained variables. -C Set first L components of dual vector to zero because -C these correspond to the unconstrained variables. -C - CALL DCOPY (L, 0.D0, 0, WD, 1) -C -C The arrays IDOPE(*) and DOPE(*) are used to pass -C information to DWNLIT(). This was done to avoid -C a long calling sequence or the use of COMMON. -C - IDOPE(1) = ME - IDOPE(2) = NSOLN - IDOPE(3) = L1 -C - DOPE(1) = ALSQ - DOPE(2) = EANORM - DOPE(3) = TAU - CALL DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM, - + IDOPE, DOPE, DONE) - ME = IDOPE(1) - KRANK = IDOPE(2) - NIV = IDOPE(3) -C -C Perform WNNLS algorithm using the following steps. -C -C Until(DONE) -C compute search direction and feasible point -C when (HITCON) add constraints -C else perform multiplier test and drop a constraint -C fin -C Compute-Final-Solution -C -C To compute search direction and feasible point, -C solve the triangular system of currently non-active -C variables and store the solution in Z(*). -C -C To solve system -C Copy right hand side into TEMP vector to use overwriting method. -C - 160 IF (DONE) GO TO 330 - ISOL = L + 1 - IF (NSOLN.GE.ISOL) THEN - CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) - DO 170 J = NSOLN,ISOL,-1 - IF (J.GT.KRANK) THEN - I = NIV - NSOLN + J - ELSE - I = J - ENDIF -C - IF (J.GT.KRANK .AND. J.LE.L) THEN - Z(J) = 0.D0 - ELSE - Z(J) = TEMP(I)/W(I,J) - CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) - ENDIF - 170 CONTINUE - ENDIF -C -C Increment iteration counter and check against maximum number -C of iterations. -C - ITER = ITER + 1 - IF (ITER.GT.ITMAX) THEN - MODE = 1 - DONE = .TRUE. - ENDIF -C -C Check to see if any constraints have become active. -C If so, calculate an interpolation factor so that all -C active constraints are removed from the basis. -C - ALPHA = 2.D0 - HITCON = .FALSE. - DO 180 J = L+1,NSOLN - ZZ = Z(J) - IF (ZZ.LE.0.D0) THEN - T = X(J)/(X(J)-ZZ) - IF (T.LT.ALPHA) THEN - ALPHA = T - JCON = J - ENDIF - HITCON = .TRUE. - ENDIF - 180 CONTINUE -C -C Compute search direction and feasible point -C - IF (HITCON) THEN -C -C To add constraints, use computed ALPHA to interpolate between -C last feasible solution X(*) and current unconstrained (and -C infeasible) solution Z(*). -C - DO 190 J = L+1,NSOLN - X(J) = X(J) + ALPHA*(Z(J)-X(J)) - 190 CONTINUE - FEASBL = .FALSE. -C -C Remove column JCON and shift columns JCON+1 through N to the -C left. Swap column JCON into the N th position. This achieves -C upper Hessenberg form for the nonactive constraints and -C leaves an upper Hessenberg matrix to retriangularize. -C - 200 DO 210 I = 1,M - T = W(I,JCON) - CALL DCOPY (N-JCON, W(I, JCON+1), MDW, W(I, JCON), MDW) - W(I,N) = T - 210 CONTINUE -C -C Update permuted index vector to reflect this shift and swap. -C - ITEMP = IPIVOT(JCON) - DO 220 I = JCON,N - 1 - IPIVOT(I) = IPIVOT(I+1) - 220 CONTINUE - IPIVOT(N) = ITEMP -C -C Similarly permute X(*) vector. -C - CALL DCOPY (N-JCON, X(JCON+1), 1, X(JCON), 1) - X(N) = 0.D0 - NSOLN = NSOLN - 1 - NIV = NIV - 1 -C -C Retriangularize upper Hessenberg matrix after adding -C constraints. -C - I = KRANK + JCON - L - DO 230 J = JCON,NSOLN - IF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.0) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), - + MDW, SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.1) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), - + MDW, SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.0) THEN - CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) - CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) - ITEMP = ITYPE(I+1) - ITYPE(I+1) = ITYPE(I) - ITYPE(I) = ITEMP -C -C Swapped row was formerly a pivot element, so it will -C be large enough to perform elimination. -C Zero IP1 to I in column J. -C - IF (W(I+1,J).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), - + MDW, SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.1) THEN - IF (SCALE(I)*W(I,J)**2/ALSQ.GT.(TAU*EANORM)**2) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, - + W(I+1,J+1), MDW, SPARAM) - ENDIF - ELSE - CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) - CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) - ITEMP = ITYPE(I+1) - ITYPE(I+1) = ITYPE(I) - ITYPE(I) = ITEMP - W(I+1,J) = 0.D0 - ENDIF - ENDIF - I = I + 1 - 230 CONTINUE -C -C See if the remaining coefficients in the solution set are -C feasible. They should be because of the way ALPHA was -C determined. If any are infeasible, it is due to roundoff -C error. Any that are non-positive will be set to zero and -C removed from the solution set. -C - DO 240 JCON = L+1,NSOLN - IF (X(JCON).LE.0.D0) GO TO 250 - 240 CONTINUE - FEASBL = .TRUE. - 250 IF (.NOT.FEASBL) GO TO 200 - ELSE -C -C To perform multiplier test and drop a constraint. -C - CALL DCOPY (NSOLN, Z, 1, X, 1) - IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) -C -C Reclassify least squares equations as equalities as necessary. -C - I = NIV + 1 - 260 IF (I.LE.ME) THEN - IF (ITYPE(I).EQ.0) THEN - I = I + 1 - ELSE - CALL DSWAP (N+1, W(I,1), MDW, W(ME,1), MDW) - CALL DSWAP (1, SCALE(I), 1, SCALE(ME), 1) - ITEMP = ITYPE(I) - ITYPE(I) = ITYPE(ME) - ITYPE(ME) = ITEMP - ME = ME - 1 - ENDIF - GO TO 260 - ENDIF -C -C Form inner product vector WD(*) of dual coefficients. -C - DO 280 J = NSOLN+1,N - SM = 0.D0 - DO 270 I = NSOLN+1,M - SM = SM + SCALE(I)*W(I,J)*W(I,N+1) - 270 CONTINUE - WD(J) = SM - 280 CONTINUE -C -C Find J such that WD(J)=WMAX is maximum. This determines -C that the incoming column J will reduce the residual vector -C and be positive. -C - 290 WMAX = 0.D0 - IWMAX = NSOLN + 1 - DO 300 J = NSOLN+1,N - IF (WD(J).GT.WMAX) THEN - WMAX = WD(J) - IWMAX = J - ENDIF - 300 CONTINUE - IF (WMAX.LE.0.D0) GO TO 330 -C -C Set dual coefficients to zero for incoming column. -C - WD(IWMAX) = 0.D0 -C -C WMAX .GT. 0.D0, so okay to move column IWMAX to solution set. -C Perform transformation to retriangularize, and test for near -C linear dependence. -C -C Swap column IWMAX into NSOLN-th position to maintain upper -C Hessenberg form of adjacent columns, and add new column to -C triangular decomposition. -C - NSOLN = NSOLN + 1 - NIV = NIV + 1 - IF (NSOLN.NE.IWMAX) THEN - CALL DSWAP (M, W(1,NSOLN), 1, W(1,IWMAX), 1) - WD(IWMAX) = WD(NSOLN) - WD(NSOLN) = 0.D0 - ITEMP = IPIVOT(NSOLN) - IPIVOT(NSOLN) = IPIVOT(IWMAX) - IPIVOT(IWMAX) = ITEMP - ENDIF -C -C Reduce column NSOLN so that the matrix of nonactive constraints -C variables is triangular. -C - DO 320 J = M,NIV+1,-1 - JP = J - 1 -C -C When operating near the ME line, test to see if the pivot -C element is near zero. If so, use the largest element above -C it as the pivot. This is to maintain the sharp interface -C between weighted and non-weighted rows in all cases. -C - IF (J.EQ.ME+1) THEN - IMAX = ME - AMAX = SCALE(ME)*W(ME,NSOLN)**2 - DO 310 JP = J - 1,NIV,-1 - T = SCALE(JP)*W(JP,NSOLN)**2 - IF (T.GT.AMAX) THEN - IMAX = JP - AMAX = T - ENDIF - 310 CONTINUE - JP = IMAX - ENDIF -C - IF (W(J,NSOLN).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(JP), SCALE(J), W(JP,NSOLN), - + W(J,NSOLN), SPARAM) - W(J,NSOLN) = 0.D0 - CALL SLATEC_DROTM (N+1-NSOLN, W(JP,NSOLN+1), MDW, - + W(J,NSOLN+1), MDW, SPARAM) - ENDIF - 320 CONTINUE -C -C Solve for Z(NSOLN)=proposed new value for X(NSOLN). Test if -C this is nonpositive or too large. If this was true or if the -C pivot term was zero, reject the column as dependent. -C - IF (W(NIV,NSOLN).NE.0.D0) THEN - ISOL = NIV - Z2 = W(ISOL,N+1)/W(ISOL,NSOLN) - Z(NSOLN) = Z2 - POS = Z2 .GT. 0.D0 - IF (Z2*EANORM.GE.BNORM .AND. POS) THEN - POS = .NOT. (BLOWUP*Z2*EANORM.GE.BNORM) - ENDIF -C -C Try to add row ME+1 as an additional equality constraint. -C Check size of proposed new solution component. -C Reject it if it is too large. -C - ELSEIF (NIV.LE.ME .AND. W(ME+1,NSOLN).NE.0.D0) THEN - ISOL = ME + 1 - IF (POS) THEN -C -C Swap rows ME+1 and NIV, and scale factors for these rows. -C - CALL DSWAP (N+1, W(ME+1,1), MDW, W(NIV,1), MDW) - CALL DSWAP (1, SCALE(ME+1), 1, SCALE(NIV), 1) - ITEMP = ITYPE(ME+1) - ITYPE(ME+1) = ITYPE(NIV) - ITYPE(NIV) = ITEMP - ME = ME + 1 - ENDIF - ELSE - POS = .FALSE. - ENDIF -C - IF (.NOT.POS) THEN - NSOLN = NSOLN - 1 - NIV = NIV - 1 - ENDIF - IF (.NOT.(POS.OR.DONE)) GO TO 290 - ENDIF - GO TO 160 -C -C Else perform multiplier test and drop a constraint. To compute -C final solution. Solve system, store results in X(*). -C -C Copy right hand side into TEMP vector to use overwriting method. -C - 330 ISOL = 1 - IF (NSOLN.GE.ISOL) THEN - CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) - DO 340 J = NSOLN,ISOL,-1 - IF (J.GT.KRANK) THEN - I = NIV - NSOLN + J - ELSE - I = J - ENDIF -C - IF (J.GT.KRANK .AND. J.LE.L) THEN - Z(J) = 0.D0 - ELSE - Z(J) = TEMP(I)/W(I,J) - CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) - ENDIF - 340 CONTINUE - ENDIF -C -C Solve system. -C - CALL DCOPY (NSOLN, Z, 1, X, 1) -C -C Apply Householder transformations to X(*) if KRANK.LT.L -C - IF (KRANK.LT.L) THEN - DO 350 I = 1,KRANK - CALL DH12 (2, I, KRANK+1, L, W(I,1), MDW, H(I), X, 1, 1, 1) - 350 CONTINUE - ENDIF -C -C Fill in trailing zeroes for constrained variables not in solution. -C - IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) -C -C Permute solution vector to natural order. -C - DO 380 I = 1,N - J = I - 360 IF (IPIVOT(J).EQ.I) GO TO 370 - J = J + 1 - GO TO 360 -C - 370 IPIVOT(J) = IPIVOT(I) - IPIVOT(I) = J - CALL DSWAP (1, X(J), 1, X(I), 1) - 380 CONTINUE -C -C Rescale the solution using the column scaling. -C - DO 390 J = 1,N - X(J) = X(J)*D(J) - 390 CONTINUE -C - DO 400 I = NSOLN+1,M - T = W(I,N+1) - IF (I.LE.ME) T = T/ALAMDA - T = (SCALE(I)*T)*T - RNORM = RNORM + T - 400 CONTINUE -C - RNORM = SQRT(RNORM) - RETURN - END -*DECK DROTM - SUBROUTINE SLATEC_DROTM (N, DX, INCX, DY, INCY, DPARAM) -C***BEGIN PROLOGUE SLATEC_DROTM -C***PURPOSE Apply a modified Givens transformation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A8 -C***TYPE DOUBLE PRECISION (SROTM-S, DROTM-D) -C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C Kincaid, D. R., (U. of Texas) -C Krogh, F. T., (JPL) -C***DESCRIPTION -C -C B L A S Subprogram -C Description of Parameters -C -C --Input-- -C N number of elements in input vector(s) -C DX double precision vector with N elements -C INCX storage spacing between elements of DX -C DY double precision vector with N elements -C INCY storage spacing between elements of DY -C DPARAM 5-element D.P. vector. DPARAM(1) is DFLAG described below. -C Locations 2-5 of SPARAM contain elements of the -C transformation matrix H described below. -C -C --Output-- -C DX rotated vector (unchanged if N .LE. 0) -C DY rotated vector (unchanged if N .LE. 0) -C -C Apply the modified Givens transformation, H, to the 2 by N matrix -C (DX**T) -C (DY**T) , where **T indicates transpose. The elements of DX are -C in DX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else -C LX = 1+(1-N)*INCX, and similarly for DY using LY and INCY. -C -C With DPARAM(1)=DFLAG, H has one of the following forms: -C -C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 -C -C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) -C H=( ) ( ) ( ) ( ) -C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). -C -C See SLATEC_DROTMG for a description of data storage in DPARAM. -C -C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. -C Krogh, Basic linear algebra subprograms for Fortran -C usage, Algorithm No. 539, Transactions on Mathematical -C Software 5, 3 (September 1979), pp. 308-323. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920310 Corrected definition of LX in DESCRIPTION. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Renamed SLATEC_DROTM to avoid BLAS naming conflict. (THC) -C***END PROLOGUE SLATEC_DROTM - - DOUBLE PRECISION DFLAG, DH12, DH22, DX, TWO, Z, DH11, DH21, - 1 DPARAM, DY, W, ZERO - DIMENSION DX(*), DY(*), DPARAM(5) - SAVE ZERO, TWO - DATA ZERO, TWO /0.0D0, 2.0D0/ -C***FIRST EXECUTABLE STATEMENT SLATEC_DROTM - DFLAG=DPARAM(1) - IF (N.LE.0 .OR. (DFLAG+TWO.EQ.ZERO)) GO TO 140 - IF (.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 -C - NSTEPS=N*INCX -C IF (DFLAG) 50, 10, 30 -C Replaced obsolete code above with an IF-block (THC). - IF (DFLAG < 0) THEN - GO TO 50 - ELSE IF (DFLAG == 0) THEN - GO TO 10 - ELSE IF (DFLAG > 0) THEN - GO TO 30 - END IF - 10 CONTINUE - DH12=DPARAM(4) - DH21=DPARAM(3) - DO 20 I = 1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W+Z*DH12 - DY(I)=W*DH21+Z - 20 CONTINUE - GO TO 140 - 30 CONTINUE - DH11=DPARAM(2) - DH22=DPARAM(5) - DO 40 I = 1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W*DH11+Z - DY(I)=-W+DH22*Z - 40 CONTINUE - GO TO 140 - 50 CONTINUE - DH11=DPARAM(2) - DH12=DPARAM(4) - DH21=DPARAM(3) - DH22=DPARAM(5) - DO 60 I = 1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W*DH11+Z*DH12 - DY(I)=W*DH21+Z*DH22 - 60 CONTINUE - GO TO 140 - 70 CONTINUE - KX=1 - KY=1 - IF (INCX .LT. 0) KX = 1+(1-N)*INCX - IF (INCY .LT. 0) KY = 1+(1-N)*INCY -C -C IF (DFLAG) 120,80,100 -C Replaced obsolete code above with an IF-block (THC). - IF (DFLAG < 0) THEN - GO TO 120 - ELSE IF (DFLAG == 0) THEN - GO TO 80 - ELSE IF (DFLAG > 0) THEN - GO TO 100 - END IF - 80 CONTINUE - DH12=DPARAM(4) - DH21=DPARAM(3) - DO 90 I = 1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W+Z*DH12 - DY(KY)=W*DH21+Z - KX=KX+INCX - KY=KY+INCY - 90 CONTINUE - GO TO 140 - 100 CONTINUE - DH11=DPARAM(2) - DH22=DPARAM(5) - DO 110 I = 1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W*DH11+Z - DY(KY)=-W+DH22*Z - KX=KX+INCX - KY=KY+INCY - 110 CONTINUE - GO TO 140 - 120 CONTINUE - DH11=DPARAM(2) - DH12=DPARAM(4) - DH21=DPARAM(3) - DH22=DPARAM(5) - DO 130 I = 1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W*DH11+Z*DH12 - DY(KY)=W*DH21+Z*DH22 - KX=KX+INCX - KY=KY+INCY - 130 CONTINUE - 140 CONTINUE - RETURN - END -*DECK SLATEC_DROTMG - SUBROUTINE SLATEC_DROTMG (DD1, DD2, DX1, DY1, DPARAM) -C***BEGIN PROLOGUE SLATEC_DROTMG -C***PURPOSE Construct a modified Givens transformation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B10 -C***TYPE DOUBLE PRECISION (SROTMG-S, DROTMG-D) -C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C Kincaid, D. R., (U. of Texas) -C Krogh, F. T., (JPL) -C***DESCRIPTION -C -C B L A S Subprogram -C Description of Parameters -C -C --Input-- -C DD1 double precision scalar -C DD2 double precision scalar -C DX1 double precision scalar -C DX2 double precision scalar -C DPARAM D.P. 5-vector. DPARAM(1)=DFLAG defined below. -C Locations 2-5 contain the rotation matrix. -C -C --Output-- -C DD1 changed to represent the effect of the transformation -C DD2 changed to represent the effect of the transformation -C DX1 changed to represent the effect of the transformation -C DX2 unchanged -C -C Construct the modified Givens transformation matrix H which zeros -C the second component of the 2-vector (SQRT(DD1)*DX1,SQRT(DD2)* -C DY2)**T. -C With DPARAM(1)=DFLAG, H has one of the following forms: -C -C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 -C -C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) -C H=( ) ( ) ( ) ( ) -C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). -C -C Locations 2-5 of DPARAM contain DH11, DH21, DH12, and DH22, -C respectively. (Values of 1.D0, -1.D0, or 0.D0 implied by the -C value of DPARAM(1) are not stored in DPARAM.) -C -C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. -C Krogh, Basic linear algebra subprograms for Fortran -C usage, Algorithm No. 539, Transactions on Mathematical -C Software 5, 3 (September 1979), pp. 308-323. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920316 Prologue corrected. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Renamed SLATEC_DROTMG to avoid BLAS naming conflict. (THC) -C***END PROLOGUE SLATEC_DROTMG - - DOUBLE PRECISION GAM, ONE, RGAMSQ, DD1, DD2, DH11, DH12, DH21, - 1 DH22, DPARAM, DP1, DP2, DQ1, DQ2, DU, DY1, ZERO, - 2 GAMSQ, DFLAG, DTEMP, DX1, TWO - DIMENSION DPARAM(5) - SAVE ZERO, ONE, TWO, GAM, GAMSQ, RGAMSQ - DATA ZERO, ONE, TWO /0.0D0, 1.0D0, 2.0D0/ - DATA GAM, GAMSQ, RGAMSQ /4096.0D0, 16777216.D0, 5.9604645D-8/ -C***FIRST EXECUTABLE STATEMENT SLATEC_DROTMG - IF (.NOT. DD1 .LT. ZERO) GO TO 10 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 10 CONTINUE -C CASE-DD1-NONNEGATIVE - DP2=DD2*DY1 - IF (.NOT. DP2 .EQ. ZERO) GO TO 20 - DFLAG=-TWO - GO TO 260 -C REGULAR-CASE.. - 20 CONTINUE - DP1=DD1*DX1 - DQ2=DP2*DY1 - DQ1=DP1*DX1 -C - IF (.NOT. ABS(DQ1) .GT. ABS(DQ2)) GO TO 40 - DH21=-DY1/DX1 - DH12=DP2/DP1 -C - DU=ONE-DH12*DH21 -C - IF (.NOT. DU .LE. ZERO) GO TO 30 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 30 CONTINUE - DFLAG=ZERO - DD1=DD1/DU - DD2=DD2/DU - DX1=DX1*DU -C GO SCALE-CHECK.. - GO TO 100 - 40 CONTINUE - IF (.NOT. DQ2 .LT. ZERO) GO TO 50 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 50 CONTINUE - DFLAG=ONE - DH11=DP1/DP2 - DH22=DX1/DY1 - DU=ONE+DH11*DH22 - DTEMP=DD2/DU - DD2=DD1/DU - DD1=DTEMP - DX1=DY1*DU -C GO SCALE-CHECK - GO TO 100 -C PROCEDURE..ZERO-H-D-AND-DX1.. - 60 CONTINUE - DFLAG=-ONE - DH11=ZERO - DH12=ZERO - DH21=ZERO - DH22=ZERO -C - DD1=ZERO - DD2=ZERO - DX1=ZERO -C RETURN.. - GO TO 220 -C PROCEDURE..FIX-H.. - 70 CONTINUE - IF (.NOT. DFLAG .GE. ZERO) GO TO 90 -C - IF (.NOT. DFLAG .EQ. ZERO) GO TO 80 - DH11=ONE - DH22=ONE - DFLAG=-ONE - GO TO 90 - 80 CONTINUE - DH21=-ONE - DH12=ONE - DFLAG=-ONE - 90 CONTINUE -C GO TO IGO,(120,150,180,210) -C Replaced the above obsolete code with modern alternative (THC). - SELECT CASE(IGO) - CASE(120) - GO TO 120 - CASE(150) - GO TO 150 - CASE(180) - GO TO 180 - CASE(210) - GO TO 210 - END SELECT -C PROCEDURE..SCALE-CHECK - 100 CONTINUE - 110 CONTINUE - IF (.NOT. DD1 .LE. RGAMSQ) GO TO 130 - IF (DD1 .EQ. ZERO) GO TO 160 - IGO = 120 -C FIX-H.. - GO TO 70 - 120 CONTINUE - DD1=DD1*GAM**2 - DX1=DX1/GAM - DH11=DH11/GAM - DH12=DH12/GAM - GO TO 110 - 130 CONTINUE - 140 CONTINUE - IF (.NOT. DD1 .GE. GAMSQ) GO TO 160 - IGO = 150 -C FIX-H.. - GO TO 70 - 150 CONTINUE - DD1=DD1/GAM**2 - DX1=DX1*GAM - DH11=DH11*GAM - DH12=DH12*GAM - GO TO 140 - 160 CONTINUE - 170 CONTINUE - IF (.NOT. ABS(DD2) .LE. RGAMSQ) GO TO 190 - IF (DD2 .EQ. ZERO) GO TO 220 - IGO = 180 -C FIX-H.. - GO TO 70 - 180 CONTINUE - DD2=DD2*GAM**2 - DH21=DH21/GAM - DH22=DH22/GAM - GO TO 170 - 190 CONTINUE - 200 CONTINUE - IF (.NOT. ABS(DD2) .GE. GAMSQ) GO TO 220 - IGO = 210 -C FIX-H.. - GO TO 70 - 210 CONTINUE - DD2=DD2/GAM**2 - DH21=DH21*GAM - DH22=DH22*GAM - GO TO 200 - 220 CONTINUE -C IF (DFLAG) 250,230,240 -C Replaced obsolete code above with an IF-block (THC). - IF (DFLAG < 0) THEN - GO TO 250 - ELSE IF (DFLAG == 0) THEN - GO TO 230 - ELSE IF (DFLAG > 0) THEN - GO TO 240 - END IF - - 230 CONTINUE - DPARAM(3)=DH21 - DPARAM(4)=DH12 - GO TO 260 - 240 CONTINUE - DPARAM(2)=DH11 - DPARAM(5)=DH22 - GO TO 260 - 250 CONTINUE - DPARAM(2)=DH11 - DPARAM(3)=DH21 - DPARAM(4)=DH12 - DPARAM(5)=DH22 - 260 CONTINUE - DPARAM(1)=DFLAG - RETURN - END -*DECK DWNLIT - SUBROUTINE DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, - + RNORM, IDOPE, DOPE, DONE) -C***BEGIN PROLOGUE DWNLIT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DWNNLS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLIT-S, DWNLIT-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to DWNNLS( ). -C The documentation for DWNNLS( ) has complete usage instructions. -C -C Note The M by (N+1) matrix W( , ) contains the rt. hand side -C B as the (N+1)st col. -C -C Triangularize L1 by L1 subsystem, where L1=MIN(M,L), with -C col interchanges. -C -C***SEE ALSO DWNNLS -C***ROUTINES CALLED DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, -C DSWAP, DWNLT1, DWNLT2, DWNLT3, IDAMAX -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -C 890620 Revised to make WNLT1, WNLT2, and WNLT3 subroutines. (RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900604 DP version created from SP version. . (RWC) -C***END PROLOGUE DWNLIT - - INTEGER IDOPE(*), IPIVOT(*), ITYPE(*), L, M, MDW, N - DOUBLE PRECISION DOPE(*), H(*), RNORM, SCALE(*), W(MDW,*) - LOGICAL DONE -C - EXTERNAL DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, - * DWNLT1, DWNLT2, DWNLT3, IDAMAX - INTEGER IDAMAX - LOGICAL DWNLT2 -C - DOUBLE PRECISION ALSQ, AMAX, EANORM, FACTOR, HBAR, RN, SPARAM(5), - * T, TAU - INTEGER I, I1, IMAX, IR, J, J1, JJ, JP, KRANK, L1, LB, LEND, ME, - * MEND, NIV, NSOLN - LOGICAL INDEP, RECALC -C -C***FIRST EXECUTABLE STATEMENT DWNLIT - ME = IDOPE(1) - NSOLN = IDOPE(2) - L1 = IDOPE(3) -C - ALSQ = DOPE(1) - EANORM = DOPE(2) - TAU = DOPE(3) -C - LB = MIN(M-1,L) - RECALC = .TRUE. - RNORM = 0.D0 - KRANK = 0 -C -C We set FACTOR=1.0 so that the heavy weight ALAMDA will be -C included in the test for column independence. -C - FACTOR = 1.D0 - LEND = L - DO 180 I=1,LB -C -C Set IR to point to the I-th row. -C - IR = I - MEND = M - CALL DWNLT1 (I, LEND, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, - + W) -C -C Update column SS and find pivot column. -C - CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange. -C Test independence of incoming column. -C - 130 IF (DWNLT2(ME, MEND, IR, FACTOR, TAU, SCALE, W(1,I))) THEN -C -C Eliminate I-th column below diagonal using modified Givens -C transformations applied to (A B). -C -C When operating near the ME line, use the largest element -C above it as the pivot. -C - DO 160 J=M,I+1,-1 - JP = J-1 - IF (J.EQ.ME+1) THEN - IMAX = ME - AMAX = SCALE(ME)*W(ME,I)**2 - DO 150 JP=J-1,I,-1 - T = SCALE(JP)*W(JP,I)**2 - IF (T.GT.AMAX) THEN - IMAX = JP - AMAX = T - ENDIF - 150 CONTINUE - JP = IMAX - ENDIF -C - IF (W(J,I).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(JP), SCALE(J), W(JP,I), - + W(J,I), SPARAM) - W(J,I) = 0.D0 - CALL SLATEC_DROTM (N+1-I, W(JP,I+1), MDW, W(J,I+1), - + MDW, SPARAM) - ENDIF - 160 CONTINUE - ELSE IF (LEND.GT.I) THEN -C -C Column I is dependent. Swap with column LEND. -C Perform column interchange, -C and find column in remaining set with largest SS. -C - CALL DWNLT3 (I, LEND, M, MDW, IPIVOT, H, W) - LEND = LEND - 1 - IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 - HBAR = H(IMAX) - GO TO 130 - ELSE - KRANK = I - 1 - GO TO 190 - ENDIF - 180 CONTINUE - KRANK = L1 -C - 190 IF (KRANK.LT.ME) THEN - FACTOR = ALSQ - DO 200 I=KRANK+1,ME - CALL DCOPY (L, 0.D0, 0, W(I,1), MDW) - 200 CONTINUE -C -C Determine the rank of the remaining equality constraint -C equations by eliminating within the block of constrained -C variables. Remove any redundant constraints. -C - RECALC = .TRUE. - LB = MIN(L+ME-KRANK, N) - DO 270 I=L+1,LB - IR = KRANK + I - L - LEND = N - MEND = ME - CALL DWNLT1 (I, LEND, ME, IR, MDW, RECALC, IMAX, HBAR, H, - + SCALE, W) -C -C Update col ss and find pivot col -C - CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange -C Eliminate elements in the I-th col. -C - DO 240 J=ME,IR+1,-1 - IF (W(J,I).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), - + W(J,I), SPARAM) - W(J,I) = 0.D0 - CALL SLATEC_DROTM (N+1-I, W(J-1,I+1), MDW,W(J,I+1), - + MDW, SPARAM) - ENDIF - 240 CONTINUE -C -C I=column being eliminated. -C Test independence of incoming column. -C Remove any redundant or dependent equality constraints. -C - IF (.NOT.DWNLT2(ME, MEND, IR, FACTOR,TAU,SCALE,W(1,I))) THEN - JJ = IR - DO 260 IR=JJ,ME - CALL DCOPY (N, 0.D0, 0, W(IR,1), MDW) - RNORM = RNORM + (SCALE(IR)*W(IR,N+1)/ALSQ)*W(IR,N+1) - W(IR,N+1) = 0.D0 - SCALE(IR) = 1.D0 -C -C Reclassify the zeroed row as a least squares equation. -C - ITYPE(IR) = 1 - 260 CONTINUE -C -C Reduce ME to reflect any discovered dependent equality -C constraints. -C - ME = JJ - 1 - GO TO 280 - ENDIF - 270 CONTINUE - ENDIF -C -C Try to determine the variables KRANK+1 through L1 from the -C least squares equations. Continue the triangularization with -C pivot element W(ME+1,I). -C - 280 IF (KRANK.LT.L1) THEN - RECALC = .TRUE. -C -C Set FACTOR=ALSQ to remove effect of heavy weight from -C test for column independence. -C - FACTOR = ALSQ - DO 350 I=KRANK+1,L1 -C -C Set IR to point to the ME+1-st row. -C - IR = ME+1 - LEND = L - MEND = M - CALL DWNLT1 (I, L, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, - + W) -C -C Update column SS and find pivot column. -C - CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange. -C Eliminate I-th column below the IR-th element. -C - DO 320 J=M,IR+1,-1 - IF (W(J,I).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), - + W(J,I), SPARAM) - W(J,I) = 0.D0 - CALL SLATEC_DROTM (N+1-I, W(J-1,I+1), MDW, W(J,I+1), - + MDW, SPARAM) - ENDIF - 320 CONTINUE -C -C Test if new pivot element is near zero. -C If so, the column is dependent. -C Then check row norm test to be classified as independent. -C - T = SCALE(IR)*W(IR,I)**2 - INDEP = T .GT. (TAU*EANORM)**2 - IF (INDEP) THEN - RN = 0.D0 - DO 340 I1=IR,M - DO 330 J1=I+1,N - RN = MAX(RN, SCALE(I1)*W(I1,J1)**2) - 330 CONTINUE - 340 CONTINUE - INDEP = T .GT. RN*TAU**2 - ENDIF -C -C If independent, swap the IR-th and KRANK+1-th rows to -C maintain the triangular form. Update the rank indicator -C KRANK and the equality constraint pointer ME. -C - IF (.NOT.INDEP) GO TO 360 - CALL DSWAP(N+1, W(KRANK+1,1), MDW, W(IR,1), MDW) - CALL DSWAP(1, SCALE(KRANK+1), 1, SCALE(IR), 1) -C -C Reclassify the least square equation as an equality -C constraint and rescale it. -C - ITYPE(IR) = 0 - T = SQRT(SCALE(KRANK+1)) - CALL DSCAL(N+1, T, W(KRANK+1,1), MDW) - SCALE(KRANK+1) = ALSQ - ME = ME+1 - KRANK = KRANK+1 - 350 CONTINUE - ENDIF -C -C If pseudorank is less than L, apply Householder transformation. -C from right. -C - 360 IF (KRANK.LT.L) THEN - DO 370 J=KRANK,1,-1 - CALL DH12 (1, J, KRANK+1, L, W(J,1), MDW, H(J), W, MDW, 1, - + J-1) - 370 CONTINUE - ENDIF -C - NIV = KRANK + NSOLN - L - IF (L.EQ.N) DONE = .TRUE. -C -C End of initial triangularization. -C - IDOPE(1) = ME - IDOPE(2) = KRANK - IDOPE(3) = NIV - RETURN - END -*DECK DWNLT1 - SUBROUTINE DWNLT1 (I, LEND, MEND, IR, MDW, RECALC, IMAX, HBAR, H, - + SCALE, W) -C***BEGIN PROLOGUE DWNLT1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLT1-S, DWNLT1-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C To update the column Sum Of Squares and find the pivot column. -C The column Sum of Squares Vector will be updated at each step. -C When numerically necessary, these values will be recomputed. -C -C***SEE ALSO DWNLIT -C***ROUTINES CALLED IDAMAX -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DWNLT1 - - INTEGER I, IMAX, IR, LEND, MDW, MEND - DOUBLE PRECISION H(*), HBAR, SCALE(*), W(MDW,*) - LOGICAL RECALC -C - EXTERNAL IDAMAX - INTEGER IDAMAX -C - INTEGER J, K -C -C***FIRST EXECUTABLE STATEMENT DWNLT1 - IF (IR.NE.1 .AND. (.NOT.RECALC)) THEN -C -C Update column SS=sum of squares. -C - DO 10 J=I,LEND - H(J) = H(J) - SCALE(IR-1)*W(IR-1,J)**2 - 10 CONTINUE -C -C Test for numerical accuracy. -C - IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 - RECALC = (HBAR+1.E-3*H(IMAX)) .EQ. HBAR - ENDIF -C -C If required, recalculate column SS, using rows IR through MEND. -C - IF (RECALC) THEN - DO 30 J=I,LEND - H(J) = 0.D0 - DO 20 K=IR,MEND - H(J) = H(J) + SCALE(K)*W(K,J)**2 - 20 CONTINUE - 30 CONTINUE -C -C Find column with largest SS. -C - IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 - HBAR = H(IMAX) - ENDIF - RETURN - END -*DECK DWNLT2 - LOGICAL FUNCTION DWNLT2 (ME, MEND, IR, FACTOR, TAU, SCALE, WIC) -C***BEGIN PROLOGUE DWNLT2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLT2-S, DWNLT2-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C To test independence of incoming column. -C -C Test the column IC to determine if it is linearly independent -C of the columns already in the basis. In the initial tri. step, -C we usually want the heavy weight ALAMDA to be included in the -C test for independence. In this case, the value of FACTOR will -C have been set to 1.E0 before this procedure is invoked. -C In the potentially rank deficient problem, the value of FACTOR -C will have been set to ALSQ=ALAMDA**2 to remove the effect of the -C heavy weight from the test for independence. -C -C Write new column as partitioned vector -C (A1) number of components in solution so far = NIV -C (A2) M-NIV components -C And compute SN = inverse weighted length of A1 -C RN = inverse weighted length of A2 -C Call the column independent when RN .GT. TAU*SN -C -C***SEE ALSO DWNLIT -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DWNLT2 - - DOUBLE PRECISION FACTOR, SCALE(*), TAU, WIC(*) - INTEGER IR, ME, MEND -C - DOUBLE PRECISION RN, SN, T - INTEGER J -C -C***FIRST EXECUTABLE STATEMENT DWNLT2 - SN = 0.E0 - RN = 0.E0 - DO 10 J=1,MEND - T = SCALE(J) - IF (J.LE.ME) T = T/FACTOR - T = T*WIC(J)**2 -C - IF (J.LT.IR) THEN - SN = SN + T - ELSE - RN = RN + T - ENDIF - 10 CONTINUE - DWNLT2 = RN .GT. SN*TAU**2 - RETURN - END -*DECK DWNLT3 - SUBROUTINE DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C***BEGIN PROLOGUE DWNLT3 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLT3-S, DWNLT3-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Perform column interchange. -C Exchange elements of permuted index vector and perform column -C interchanges. -C -C***SEE ALSO DWNLIT -C***ROUTINES CALLED DSWAP -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DWNLT3 - - INTEGER I, IMAX, IPIVOT(*), M, MDW - DOUBLE PRECISION H(*), W(MDW,*) -C - EXTERNAL DSWAP -C - DOUBLE PRECISION T - INTEGER ITEMP -C -C***FIRST EXECUTABLE STATEMENT DWNLT3 - IF (IMAX.NE.I) THEN - ITEMP = IPIVOT(I) - IPIVOT(I) = IPIVOT(IMAX) - IPIVOT(IMAX) = ITEMP -C - CALL DSWAP(M, W(1,IMAX), 1, W(1,I), 1) -C - T = H(IMAX) - H(IMAX) = H(I) - H(I) = T - ENDIF - RETURN - END diff --git a/extras/c_binding/test_install b/extras/c_binding/test_install deleted file mode 100755 index 8fad419538f6119898562644b5e16b8fe210af13..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 276896 zcmeFa3t(MUl{bEGA2diX0gFZ~HY#9>AOVXe3gfNq)l;~2E{{TdV1uO)w3Jv8!+jG?h=#Fx)wsZ0VF0<$f>K=fOR7#%yJ8v zRLej3)yiMr{hzxCQ6ysBa5-sjQqv;^ZqqBZ9_xn75jQQB3T?}he7DbbLV!X>11HhJ za_y#EyD4YgT7xg^T70rP{@Y{H3*A*n! zU!Q<45@8&FcW?ONmFg?~_ZC!ibcv*|Ag)yW&NBHwRwn) z-&f1D`|C3G|Ex^@C(6XXvrPP_%hbQUO#F8Mc&Yxr2Jy9pokF<1Og%p;6MqDVqE!87 zm8pMWnR-Z2rRqtSiQiGCp0AaOUtXr33(MsHaGCs%m5Ki;`dbSAe=C!}qfEPQnR=?r z)H6~het(&I?k|&nWf^!rQzrhdGW9%+_}8NCq96Ft<(FNxxoz_$o5+REh^$+8`IT2~ zT6cBZC7avUt&6N%eZiV_mu}d+;qoi4ZriZ=f;B5QUbSh%1($qq;|5JDonq@mJ)5uC zbosiC8#b+j@5;zJKV|(@o7P{_W-^50uh@ikHeIrD-Ih(Qm#qJADCO$5t6Gcm6ZESu z+pu{Z3tkTQqnod218{yrSGQ@@x=R6hDE_Le*KOFm`KryKD8H`tEthP*WIX^Ws%`U@ zO>I|Pxj~DryQD2t+BOu5@;f740kW?omfsxNxcRCrn=UoZWs!|nU4B`l^{S6XI2>19 z*~(0(Mc(z-Ym)0WUWHC?Kwb%5(stFASFG33(U|qqej8+{-FodNV}t@wkNY~FmuhRwvpdc{@imbR-wmZ)X@hu5ud`S7~SF1cc3 zq!o14c3I@g4Od>hp^eV^D_g~B{a6GPacSgAG<4N^6kOka$-2v~07YH#@eRyz=lQz?pK-crzL$+ zji;<+)0ksC6kn-DX9enNU1X;{QfM@mixMjfUc_XwHOs);Zhu8bMQ2fh6 z_0)&rDRbLjLn!{`HWF?u6#t4)yc3GA3B@Nv@kX_h)TU7Uv7!9Uq4-yY;#)%TR)=JA zYbgG>Q2zE%{HsIpouT-pq4@4ld~GPcClvphP<&q~{3#=+(bsgA7q%Ow~0Xszn5W}+$Q=Zd>+Fz zwN3O$_-ux0Vw>oc@H-f$`D>z8!f$1mCdY|p37^g|O>7fM37^C;O=}Y|3BQ(Mn$#xh zC44NyG)+#_O897oXOcUC~poD+QFimF@{Sv;1VVXWCdL(=Y!!)5ybV_&^!!(^uv`Y9E zhG{aJXqND|7^bOgA}Qg2XP73kiI{}{g<+b;Ch8^pPYlx}Hc>0#&ofL@*hIC2|CV8z zz$PLR{v^XReN9aMiT(dL!?g^LOL#NGG<8jkO87$z)5JBAk?;o@rfF+pP{QwJm?o`> ze!u)>JqXK>^my8DSG#wAz;PdTx*nNKUXVyHeDe=Ln&~6IcPE{*b|UA2V_u7T{?LP9 zBL>JxFC-l}jZ{N3A~om2Cj z=w9dUr`r~zg8QD*3MvkaUsknrRZyPrb)NNo)F0XMhP6)DS>Hm=h~xfOTczWjbu$9F zWx!JIQvBJwa69rvFGkyb`z$~4Q6$o{7Ufo4wBo`QYgb%wzVnGkhcS&Vb-V>9&?4u! z@sZOqjyvwSsd0=%HuVSmJsm08)D(Q2GTGEq@R8WFDN-w^o!85Jp5&>zanxDA%jwER zQArarFy!vM71<)<-TOW3O)vgFy~CtzDG(jKmHt~8>pcE@=fk7bjyvj{5Sc_Z?k}BX zyB&ATY24FxG$7}Ggwyqz<|ufv#MI6CHQDD$q?hnMKad z+SVBGR>1Tr*D7NQ44l;Ng$fv>0ONyd+qnV zUg9Ufg&;GBr~oUDVr8|vXT=V-hm_Us-W4xEyfh15mRr1>nd^K?@G`Q$s(Rsa%#i(6 z?-75!_?vbDUo7LLSjNW}1He}pF~ApNul%zXTXm^^X7bsfuZyr1@B4MxUw_9l#P}K~*xh(#fbN(@zoQ zxVr;HwIiP*YEW@99Kwm4>etADP-J>>ig1Oe-*-dP?~eu3?;&T|PRAX2wx%DZUTz+y z-#jp#PNfaMGx2WiNsj{E7XsQ%b!udHD6&LPz7y)nW6xhtdP)qG<%aP-?NzIGpgq(9 zH`T0>EuqK~gj_H_8L-D)&LLcZvd+6pI?g7;W9bvzQn-C($=8$qOW<5a&JH|)3FSSa0KM!y>j%)T2`<_@MSWrt|f z8>DZ|*;H*o-xx0HTM#LI`^qj$Q@1~6`?d_Ca+lQR_l>34w?m@(GtabCzoY;{hKnE! zA_c;a_z=F{hw#&opu1Ac=tIcBL1BLys=wu(0x+n)rT}1uivSKH1>kBQ;A5|%ffLZFG00y~KpbW|T;AcP@XQ{z?lG)Vaf-W&!)TJO&y41VVQps2T+jeQbbcq@L zE-^6sE*(mD%Fcq}OYAJDw*7mjGEs(u{+(19Dg9gM_iy*_O#k+s*p*^YzjF*+`*pBk z2bpt65D#P|j{88ueZ=u@$jKsb!?-vXk6h}!X^AL^Z3}a+o&*T#4P)d{?zn@uJuzKL*kbH)y zZu$7JE%c#eq_0)7BTMqN77T2#Cn?Q|Cu9cQj=DhEf3 zLWK!%1}P%m85CFzArSwkMzzeCEt6i*%d)pnHi5;&sage~vbh@`Mb&Pqog^M6iBzk` z&%S)zb6o9Z5C9|UE2P&Fx3biysI zc7Ft@0;Gs(Aps)*ph_0xRj39Ps^J-+`qVx_kAphaxW8Wg_>X-g8M;Wt6e2qL5Z#{- zQ3En0g!V)n4Chsd`W2#q0HTru_J`jHMD?aR!IRL3#ghe$G7&(a<2Po=HV;)?n3ZH@ z!S?f3SxV|r!1@BfN)F)r6tEgood708XaRF&;Q&ZVJ+7E;65hol32$xYd!)-ms%_uc1oWuyDHBVNe_)P;03KaA!F{pK%1hADPfo1cU?XnxO{^nyht z+pP<=OJXT(_p7LuQwcJD3!Q9g5G82bhPNMHP6>Di0xx5kVQ=c|@Xgzs`Uaf&$diF9 zv)E0Iz>An+8v{d)^}4;|@Fv`Ej53cAkbLDW7_2NB|?CIL&r-7%#g>9p$Q ztU)!cC<}3!7;1*sfYcIr8OscNQybv}NLRv%B6}xYmUL6y@FJ$&#$;1{*6a56!<%r2 zdYA_!q97$TB-0CKRSj`MVHjoFWW_#akd;BYfovr3GFFjwCwzeH2XKh2akvJu9K47b zvoUJ-HOPtxEZZlU#}fe%eHqk{%r7@JEFnnNz!cDDF$J&1RN!qk8GtGHqQDd#ljNydn$QG?zeGAs6eZF!cu-?GrJQtc53{9*DkZdoGTnzF`Tsd-sVfPW zT}kE^;ocji%Y?U`^CY43*xr6DU_`0BnV`b32;j96;kq zIHuKKbX=rd2h+ZC5t0J{2d+d@L93sx2PI4GRoJ zrsH*Jtp=@Dqeu;^BC~zM@zzumr;owFAKf=54fi|V)=nvgy_$}tPP!E&;c(`(3!vX} zytOs%^1qcL5A>i}R!5QKlaIi)b1<8`T7$|Zvbjq&$RTCswHjod489XVY!yu_D34)& zKu~UAFWsSfaeC{-N!PN!ZmLF{bTuQfsKA+CP|m@`Opt?&vk{cXwN$A3GJ^7$W+ZS2 zAt;YZsd%j^Qbt5>C<1*pB658g^ch6tx+3VyiO3P+8zwY3!nj04t}WG6zLf0C`!z*P zbsBj;Bq575KFOTmvv9O23jWoF#jRXS@(KhasUV{jjMxf1i|CS)v#&2y6gANzq)V-; zK!BEJ2DO=C+l*>hMU}{O&_zCg(+Y6?TE~E`ql_x>Pvby|**y$;Lxu>_rW3AtwM$Vr zAb45D6R=UD8=R`)yei-JC=`7G6eY#T#R^3Xb+9@SBL&w1NDT@S9lseL!GbXGK!2{7 z#as|f9_bhH1>8=Bta}E?KK={A5BaDg!ytGKvj-8NftK2WW{i3gfK-DFMm?do7^GGO zseJ~Je*K_;RBfsgWXUATgQ^0_fQpXalCKGb5EWrQ(eGuC+0W}Es#&3GnE|SE6{;yL z?5s|pnq*N6l~qwDnZrxb2{*PH^Eqz>DIXc#iQaHtrLCj_))W9%Qg<5uIUy3si`5BW zJ*5DnBnA-Zgd0=kH-xcK0Zf!%dc%1Yu$Tho1b~$!`lSjO#YXDV0+>*x#h9DggEWAo zGtN!j#;m1uryN@p!QC4^25@>ZNQdE(Y_RNcn> z=7&bLd8%#zh%yF=pltJ8b8Yh^oucN^-T-v9eqShjAKGgO+N%%RLwBJ(rZa`@L3**O zV!X~aMphFv2I&QQBBU2HnR_`wu~PH{JR|7$z$=ReG>E{23dnLMBvjgK z6q;rfFv(|9Xh^4YFQ+ML%OKL=Y!F@p&T!ymtm5o8_yE}sIKAnV8uqY_)D z)hTq;GFj#B`Fb$b?n&f9<2g8{)n8B#=7L2%m~+^)TE`(!zFwQ(>fO|XEngQV;4P*? zS&g2$iw8vmh8_&IPCa-`T1=0^@ilMg!PLBAUfjXC2|bwlevP(B&AVD+Lz*{M5?}Kk zK~?PMq~pa!51tYY7%K_vj#x=#lfR@Y+yrEM%kx!XfXE2|Rh<*SSJl^93RT6N1ZfNe z6$&QQ^&JrdW=VCO6iqOxuGff%F5}c2N8mPJ|IrIpJ@Oa&h+|u zw`OErCgW`M^Uk8`%joCrnvuXAgnmx8?L%*M=rUTmOmwiQpoQ6J>EomfiyzxUnT;%& z)OjtG)6#ngcS!URU5JbTO@#o=SJ8D3tXYe;z!5&4SD;`cOVr<_7HBF}ptN#smEM?^ zbZp5oO79JK18&#q>;WZ-E{+bhfN;ZNz3L_bA<61(bQ3P*;k>E>)GHtj0U#w+fF%kD zCrY53u&5nB?sJ+&yM#8*{jUJ|MjMy?FQ+6_wF*_;3{ZV)RM5lO?C*btnjxb?!*q%} zUad{k%+SQ^v28gw zPV}&57PW(50Tbq@Lb~6WuTqBqt6;BGrKZ=<>#Nk0oHrpmRC+;4>UjEx0$9XUCx9ix zfVnD`dnqMNH}xZM>yip$H;d`+Rwul&y4v+N-6Jt&*7IQ`+Vz}tS|mmIH0YXDw#4RI zd(eDqUi0NQ*9JoEk`fEs#pYVP7J$iFI|>vCQ@fM!xP}|Nh?{yq{jsW>BULwNy2hif zoa;q)ClvLlbNTJ>EB8D1` z#DIxfFLt2d&{w572Nd>;-K8i>KSq5GM8I=;_WvoJWCwzeH2XF}4 zI9vl66&J)%qcM<8S+Cnmffb7BB=h)^`yfIP=Z7^?C#u~Pt49H&%GAPZ;HV3{j8(nw zWcUEmDR8LD#ONYFI_toTm}^IYw5ufZ*qsB}xI{=MENu9irZcryCZehY z23eg*H;{D)UdAf2J_8>hOT!_u`r#VL2H-_ZpN+u=to6FR878{h2kCfXN8|FMA(^qz zXf@Q%Va%o`F}4O-MVpBMA56Cb_>fsF ze=|`To;Ih9Fuyr&CUW+ftvz3*F`J1{X@)o{LYs*sbhDXgltpSMlo8S5qLSJPmo}@Nl-f+(!Rb;`iE2ecp%R7G zNaue3*M;^U>rG4hu>&c3&>gyMNexIB*lh0UEGW`4mTd07HOP|GV#YPdp<(cD4U#Yz z+@(Q+#o$c{_RO#)*^V>V*peKkFyIaiiqktFPFgfQ9MvH5+;k5ky%cj!uky5LM%Hx@ zDo=A!^<`9^Ce29T4npNgN-4Wj7B8dh^gStk41qoyWv53=DQ0F+cDglh2>No$PA4IT z;RuefNKtk=OEs0R@AzAi?L|#>mf4bQ)u!70rnn{9T3Eca)+5SNOe=6~1;LJ)(4wvh zz6k2?n6(r&L8fV>R(ky+s>Ic6GYz&GK}mB_CC#j)a7$9)tknwYYz1mwQ!-L}rOH1+ zyH=^I){-^0WErJybT{EQ%95ovJ!hoHjlwnSPG&%CdNf0KGC9M;c~zr}C=?X|6eVT$ zvlR;RA%7=RhA0>pVJNz2`px*`B6!Zj4f(to7kd37fi}TWfEWNrsI`nXF}O?cQ_JdP z^khWBTtyFKC<6>PqdS=)WK~P=MA4)-oL7-Gt{~-R0O>ddslrqj-T~7YE$VNC5G$AV zTk_SeevF49B9SCi?V{Ju>mzDZp&FY3s!#6}L{ZZ4cQRW!`gy~WV=|1fC0oj9OCvM1 zbey(C*#=cUjvTVF66GN$D*HtX}~e2mmWNqo%$mfDM}Jgh(P`z}(bVkp`?Ng}SM0 znYGk5X$y;~HMtpHXu+Xv(oTsfqXiEj(Q3gY*FtTSM@+TvdTX-eHffXJ{7_Px4{ei@ z!b0+3zA3*i)I903sQHrHqf($>BQnN*i^5V^*sK3`-EiCbM@f$wWOWp#;MoHEvEfg_@$3ZU)yo^<) zg?nUB-?&FcrG+xKQCdXu4(*X)b@vl{d*Fqx+X)Bb$nnKYh-rvqL8V7S%8PoZ2q!ia z5osVBgx5eu{lIt`tB~CWA0XQShmeiJHIR+LiTyc>{ciBIHO-ugEHXM1YX9fez^obKz1A)>X-F&ksmcv!$SisGuYs&R@G@3$b}f8>Y%3h%tOu@v ztPftqblVs`Lv3(2h*+2j`k4nzK_P3_P(&eX(U1u5Fo_`2AZrv}1JYRFWvn9W0r;R5 z|C|m0n53)7nt~TGIU8g4T5)PZ6Gq_h2ap_bdSi6dAY%|R3b1VJftRt0kO$xcLVga1 z2$_UyTZfme+Zb%>qu&N0)$qb<6CoyyDF9%x1PnWb&YUSXioDlbr;x=^z(7_HuYs%~ z@G@2*I}<)Yb`~5$mV|2{Yl0Usj*Y<_v|hKjm5FFpfoRrHEn9cxTshKeHLXt5a&)k9 z4VpKQRl{o_s|mb}RmhgWhY>pt4k4>&P)Do*Uc}Vd7`ykCifBRw9R6U(hyYozW5~oy zr#lHmx;Msb=^?H*uw%#?lunVG(IzoqT=GDMSts3Y6Yeu^t#LUVOeeL_CA}tdzgp?r zG-?QmCp__c>_Et-!TsS*lrwv#MXOwyHBHwsV`M<_fX@f}!{m2pbqY}CwTfj0XM2WP zgI0sZEuECuGObRcD!Y>EvX*b!;QsI!^1zZZ8nl|XKU^KO+U+lK=}uYV{8sb#heuGA z?hp5%aPj_dMp{e{!|{zNq5a{Av?%+-?b;%ZDOA()j49#$;XzczewN)ICiC%46-z^= ziX;*WO&hTH)XPw$IX8Xl%Q`!GWPf-E=Ze|JZc#8{fk`(jn9-6J7)~~VS$cmM78TAo zAIz{tW!!X-78QrI6SAnV^E88e{bsm!b;#znYmg6`W)($m>zT7PB=gjA|K*Us9%wS>anqo`Jb9Ptqy$Y2BsQkU+ zJi2(^?@Eq*Q}870(w_Gf`mlJi8a6p822dEPP(UhUZ$XFYM~{T6U4hKVpG3Z0p+_mH zFQBB7itMQh7#DKit{_Bc0h_xk$pM+WE2;1K%-xlQTwp|X3L)U{lnW&W)=uliPPI&^ z7x`UDKByBuI;wss0!geSR0t?iC373^5`~}{(lOT`$jU8n@&)t~(i@hSpj@w| zXld{wGYHCcnzuG+p`4%`K^AaB+9yPA3Ge3QHCdlW?Z%++drPu7iEX1_gI(@rK4tfBsNQ@j83cw=&@LPbf&*9T<2 zS*Wa{A_kJ@@y6t*zAEUVna1A=?9sWD$6m~ygE&5g`6_UTJ&a0C&-}*ZZ@(gd(U|9} zz@1^h=59>xgZ*^w#v~U=vyrElo3I4YhHv%^Chf|phbLuW(leR5XYdr#v77NHINUR! zmBlC`G)^I=!p4Ml$L4NK5@&NaCjE^ka48^U?#AReXX7+CCW}>H?tcM$RC^=FjiC~T z`!Vy9xeXa#4X)*)K6h_&?%pKDT-_MGqhlSozeu>x!@bFoFUn$LH?_W_L6z#VxqsIn zMNjJCU(}!o#|VB#gOuW#x>bWsCb$W~nY8q|dy~H8>8rQ7|CJFL1j{%GU42|jjYz2( zboH^K7Ru@BJ!F1=DfcF?>?55X%)Lpz8=CRQ!Q7h^MS!ZfKXm?93hgUE7u5`r%F3K& zedHem5Ka_d5fDt&Idz0^0s5qPby|91?^$w1nzbWo`wRXH_hK}$1f^=MTb=y~~ zCJIw2*v}Gej3-7zaL9_OkCM_`3`;~|@$E}x3?b_jmKqrZ^RP}cixvVV%cSEE3wq+?JG>> zRtRiH?c$jxqieMUUdF20^^ERNexnEVpmpLJJc`>U2yuvLtkY1EX>)fdacncGL&doZ z^i*p|Chy!GO2x@2DF<7QaQFi)HPCtC-l3E)L&(##)RUh1eah%fzK+Ei4IQf)PN}U% z<%560_bI7dadOPvr}W=*r3Av|ZMyrE|KDe2-YApF=KhZcMRtL*)1$!{XBC2<(4eyK zY;Lm#TTSYE1ZPr(=I&F5H!S7yhrJU+aX3DklYP7=0#?U;v>7)nyfA0H~Pr3pH*Is|0GbY-%zx65%1zYpT;_EX0K4-mZ>it5{ zq7|y`MfN%A^^5pA=p^UB%=amq6*8(&FO>U~Kj;=@RS2@oKBvq*JEH{wq8B}n_bK0^ zP)$_z}H$dEONx_8Q!P-!KbDFVv4g}w%Rezj)Ak$2@knG?Gz#pDlyN-eaaOI zi|$n#?YLTdoyT4EyPD7AeaeAP36ch-pXS-wNEk3&DN|h0f@<&a{Tc65b`#RVPj>Lx z*(O4*_ZyS&n){7#V! z->1|IlX>?kzofb3K4qu)=k8P5{oA?wl-QA+yH9BiPILDuW!3$2-=`#l5AIXSt?~2@ zS%cK3K`us{200sDGCjKFhjeMLrb}K)mpqhit#LE3{xO^Z*QZO1V>0)efAQ@b)KFpH zsD@K$-`9DrRPZ&|fS4MWZ1=+~9pdlPspfDv9-WPT)Kc4SAK z@W&@bC&niwM^}7DHVAf(&zHUY&^HSo`x^om&j2vC0_knxrlfpnnGfHw#mlPxI|D(E zL0XZ5;7wEb?yKY7IteG?b>$?~H4ewaYmq16Q*_=K0{$)63t80hwv93)zW)xh-^ z0(^bRaqq?zi`&u4w#z)t54ORWp^TN}Y(q7eEMmp{Yqb*?2z>ayagq0etryp8!t+av37@_73D?r<|P+&3B@A z;N$151XA({o{(pk6P<+VqFoYnyBcKucOO4+V6_W|E_CRmk9qo>`H_VCE0X+0ADS1r z%&EFA0}{jIXHsT$d5~HnjD%8trK@%M5g!e@{W`r{xR{#Sf2qn$sFAoLRq)$Fd zCr;y&9dA=gy#qw^(h#LCcu3>_b4~ivBSHV9Q%lB2A(0;t%Lo;G-coD^t$9MRgBTYO z;IM$TZIDoSH%SN-tMiVKEAb9Ua#uf`5b=g$i->o1KJoUUB&y3J-o;OYV(}GI61gE@ z_TVPXYYF&UhJYQ6kk?fMiUo;Y|850nR^)s(^6KEFlTkBkS9$gBw#7pJ{JW}gvg-d> z^8dMzzszNj9@|ABPKJbc>lEwS#(Cqce-dmmMyRAB4U_RE(#^0s%`i{0@jjUum?0Pl z5buToeo<&=?(Ocb)#+8o<4qEsajARS^u@(})lLa!`qgX5Om$}9X<9VT>cApNXn=c+ z4nFEcK=I-ud$T%9EEl8`aDE9FZA} z_)5%XnZM*hWR>8cU_V0;Ib>G*Q}ujjKKQ{8IaR-YS@Be5e2jh4m4GCOf1x?a^+96H z0%4Yr2qtZOSZ1w>i4W_n<@n01rDvj&v$k+5Xa5v#aA9t>zZ#jk7XI8s?Thwc&SUKY znE$wi4B!)cxMEK8Vdt8|Faqw58i=g+8)a^<+=_A2wASD~{3+Ne@i?S0S4Pl79YpP zSs9aWI>`Dr|XBS~h8HTr>cineE$h`5=sj z%f(_SI2?{iCWC@b9_%BMP2VN5a@5_RU5F<7Y7oI^U!*?mwVu`Bha+73eQJCghX&)q z?ub%j)7YJMg-SC^cTBnb?(~GSNq0KKG147VFuyw_aR4j1F%%MXF=zD?sJ1VXZ2Qv3 zn%xlqH^?sFNn<#Mh=i;PJJkwJ3pHvQJJk}7kWQI$`JLi90#P1Z7ZKv89kWLjoFozFy6b)08z`+D|$MHk#i)7F5NX*Y5y-4~&c0uyz z!>@vGO7a1I2@3quu7zKcE&SYQR``2#Q2OkkbZxDTR9%0waO!w1A?Bj?uYMR)8Q)}L zA(BuMaGmYI7qkO)39r3wP3pjw!&ZnAjz%Sm z8}C!E0F9^upnEh`fF4(%kx9mbne&0}Hb8gFW|9GT#0R)l0d5Zfjz!wq(LhXrZQDqH z!fOSfe*~c4HQ1G8`$z~g3#@SSVKt&8zeR7nzjq%08IV0H5Tu&5`4-!}K7=l)(|5v* zw;L;u@$#(=@#^bUs$J>JZ8))l#PDW^j!IHnX|k=9Ib+$miNh#Q!(fER!75DUQ$qCm zVO*>-8ln?4C09RfN>FlA^7fhp2|-v7irJf(F@?~X0m28b6bMHH2+Y+!U6?~4S8I$o z{%6Z_#UL{(zq7pQ0~y66NT?*p^$K#s3?RQjK_1g~q*mDvlY2#ZSgzMBbczvFtF6@q zt(AP!bH_$O&!$#ZeARr?{PJZKoz^r{v2fYqgy^1zGV<`2eR5%02(0q!`iq zD`u$we?Bbzs14UIl~-#Fonqi8pO9`(!I5s4q4PeiyrQUb3b!BzI>nWbYvs8aDu0_+ zJ}ClEcoNlX<#d9|Ic@NN@2FNjW-Bit!9V;VL5Vr)o{#c6t(#79-5ITWB&d5{p{eCl zT6e8hqjje;9V>APst%JGZ;`b~(hiD!zFNAJutV~9(v?t2dux%FUGTRr0qRAje_-OR zZ-v*;cr`p3VGNDCu05oRj|eJ$s8K5Jm--GB(8{2`&q;mqu`qN*#Kf$;?y9zoR1Zc| zC<^EL121F6sFC^-eAs8%4hNr8l!36D31!*Z0yU2X4}cJ!+L?n@0oVyO{4(jsOITA2#lFL0bdUI{Pz zML4m9HzQ8E-%d`20ZREKfWAS;Ym#W9Se6Z7b7d48gg&W892EK%~RF)Ap_PdeGob4w>! z+-HH7)yvDE<){}OTAnphIpa-baB_4QCov@zQ5T=d(j!{tG^CPzp^(a}PcMU(m%ZrF z@~n}{OHM0;lf@yN*w^w7lAYj1WQr$bCluoH*hz0#Jb8xV$E;cCarI?7drZ(-+CSP} z1`WK{XyeAjy->{0?yjzfqYh0Bl1FR@sf;y)YaV?4?X*$-3LKISN$z~Ph3A2ZD^3N> zYLs~kICTJ6)%CBJ@Y(^y^#i%FKq#n(7ga`4cDypP4GJ2 z_8fI4ce}$79@F;IQ>~Jo8k6)?v!>U=G0oM%%O8$fFcu$#?E!e*sH7jkLy=jEI164G zA7Itt)h9J7jitsFu8gL4!ZC1l!>e!^q4sRp-p+$%>Tbuyo5H)Ix+k2v2S=yxcJH2E z=xy9Nqg3~;Q-J+alI|-wELht1LDKby?%BYN&M1HA%A&{&-7HW<^VYK?<9_wzGT5jI zW8>MR6v4)`Ln$+&Vb=U-`y0xj;gumYYyld!cKaKwaq3s3YI$W~`v|-^gF0V#O&cHU zfJV#@OlPq}21Xn2lM@N=z%CcISMibP2V|@DW^79>yzNxkJ4)5k+SIkRKGJp~3gA0s z{G4TVn$dQ9*~T7aGdq#C^N<-V(T(5Mwe_}0$Jx`WdIYP4qJFIH=K~X;J1G*$#&1jR z=5*NF5NUfK>bGC~h-cUh?we(<0TCX&Mc`FILv?6~-T(d@rTf?*>)INFh4@r(JTw`z z7UHE6w%e5lIU~(dM`k(*PNU3JZn)qcq?wA-aU+^?r&Y0MO=FGA%Fx&nixM!Np;quh z-HmIU?0`jo7f1*aL=AY(Wt@DxYiBLK zfI#nRcR%*z9rv!>LqC(P)^r52B?ec>REYPGmfKfbKp&WR^7S|bfyNKOf=ijj>!mfy zN-$AcJ8BuR^Wk|;bQDk5k4y3p9h~kP6`4A%A^F@2cDB`I**htnd9;G31EpgNE9OTc z$@3EKJ-LlXW9zwV4`dGc+=tG|lQRa0(9;fBN6~~JQ)6{O|0*IugEzpLAG+Uwts9v8 z){i);+uL62NWajv4(A`8$DhFdO^1wk^8#3lOsRtqRg?)M>Y} zaG`auPQb z`Ga==UgFK&{uGAIlkb5Zs;CB?LW%r=iSM2O?;$X&I=>3^wVx1Satwmeo2fA=K=SX~ zBsw?`GX5HNnkneC*DF%CtP@JLKDl}edbo?X9odnMJF>8^_W0G3LcASf8uIsccVd-M zqb(n|J%y%ptTH%R5p~j=IU%^!3_4waqOyO(lNFP)+WgS44f&`~Xm)~`AD)fh$wAn+ z2p$=-_(<1eRIG^P8Xk|($mkwEDkGv(1^fEBSH9<9`kMM?Esj)d#so88F-5=IG3*9g z(&1Kw0emN&svGk=yv#|T4GJ`!UQQiG;H&J0uLULC%0cPuJqUBU`$yMOe-OO#@2bXJ zFjoI1r(Sl9AwJ>VFe=V=hQM~YGh-nGQ?Ve?OQ2!xuJ)u}Zg{L`w7|}xPA?{Ggb0J| zte>2&8leX%DL%i@s8$X#01F!wkn}u4)s1^W28)2g{8*d=I+IrCoI#zFUak^JqVb^) zMn`fOrv#n&`?=giq7+fpQO?WQ2ns5M6GGvFfNcBYAAEaR6`x zJgSaty$I5N#FE93@xTioy?ud~vC6w?dGqB5AJRd_Dx|~kl55$R86fRs_EL~`GXcaU z&QPs5vVJAf3om*d79boNNFTEXzFhpod0;H0VK5fdg#kQr;|Ua?cn;32Q5YznDqYDu zu>j-M!Imm-XDn}{B zY(B1J;)2n4rxzTx?`1MOZe5eQ{krp4$P%&doJ8a8I2KpF#;SiXYxS#2X40Ca-l0`) zY6&@Uu&fvc3E4+jD7X=10OpZJr!*&W<#CAVD+yzR> zRwR~0;~gC*o(+6}0lpRKWEtdjTocuA*F?Ti#brW{H$X}b+A&9ut=uPNCowmL5l--A zpeZ`z3iIo^73QE<7lIG7{*Gs|#0X)bf+WUH8ModY4KFb(xKj8;WS1C-%upq8 z5Rx1@eJ;6+pGVG^>k?B0YCrNH(i&qy4b~V@RrA)E=|Pn>q!g&rtuepH;bdK7Cg96G zw6u7QsaQJm8Z(b;jM1Se7{2?h2gT0&U|bEDOK%D0=1)~hTU;SZvp6m#x5G@{we`+O zmHVJ@7iEz6L_8RQX@sKYkkk;YWnd@sjQTxgO(o{ka&HTYhLz_B0D!JJJ7NX3HX#gP z&H6$nWsX_kVE$`Vc-;$$oeac5R;$gAh~WCu5EAOS(3esivI}~^R3a1WVIh}(rY^x2 zY^bDZn`?srNnU6Z1aT&I?GLpwpr`jyf?+g_#n3hK^#yrZ05ZDj3zGNHBz`VXW;vodu{~eBhtR(S zLVr3xb|-{>l2VRThv8feTYwQ~ROmrVe^EbIo&_Zs zC=*Nj@2jpmW+ko+T~>9`9TfSiKKX9!<`JPsA{Oi|6~i*;6P8>LN;fETh|x*6M%~e9 zCW?RVf^P;H9X6*KdnIGnu6fbh-AYKrX&&hXqwWdU+?AQO*i!br9R7zC1y-w(xKI!Jn)d&io7ZZP-ICB?@yQ`g1s~>0AxUsHbl)E zQzY5o{-X+f%wxq3Ea$xcC<323Dd^(<;|i2=ccZFtMIlKsv>=w1G-y!=CackMH(NH( zYEp)vO*uM>WzP%;7cP7#SkMEb~2(W;Kk-1IT+;(I#b z{y6upPe*BLuSW~gsm9%M0aN_$gSYi7X+K4l*v&oP89oGLX99<3NH*@Vps=|jlQiAJ-Cy$8hzU=tIl{e>%5}4t0 zW^cI`?^}v|vv-lE9|MmwntnaJnBdbM?FsDOR@0v|N?3O96&SuhP-&*gHos)~&g zSHHAa^er@e7aAqLgKhW_+bX;4>CRkgK5pVpeDpCGHYTp&sjk3iedjD0zp3b!g(5}D z2Kr@HbtC($-m`|{o9xAjp!umftd3Y^Mdo^OSSsYi22ax2(;97WL6_2XDqG1n)hw*Nmc$UhZpm+t}E}1c4512;;$b86T({pUi|vE#c!+n z>|d;1^Gu4#9{yPFNS5Lsf_p<~=1<2d#L~|LWzQme5+!gFO3uV#57N}Fr+@Dkwr!6k zS6#nX!g5|@l~+-8RAg1-NU+`dkH|Zl4yh(n^>=HvZnY4uf;MY*a#uC34Q=ASQF2|} z1D%}564$t6rVZaFN#l75z6siz#;%TI2q9RD1pYJU+2X#Ouf|1VV_EDo`Ghyblap8y z{^+>-S4Z!KeITvJU!mac$Z(B_{&AVN`DQRff!_8bg(S#+3W$ZzQZ^*>TU_g7cW5EC?8HtKT<;8{i zrO;J>G#`^Vea3y_ob^XIva6h1e441mk`-F&5QBLaZpG?@Q!_j=YWz~6)^x`8S|LMP z;ci?EwOLW&rCK3Nihv251XXxbq47(F-3p`-C67 zt$~-Z5Y8fdyV~H3?(Nz_2Tuy=+izklHBYZaN98aEs(eNVA>Ur=AY_>a(N^h`k=PmA zrX4gVBY%UFkrgX$lcSOE3KIReH?6phoi98bdCn;ub;XruQHF;iq@sB05qmr`hnbcD z=DLX;BC#}rz>3{2Zu22)r_Gw}YK9kc0mReQ4lnWTbyf2?0=W9NB=gIT;Wmd}9w_UI z!MDmi9*-E!oKN(Xw))v*g+TsJv_4UZTf*!E+arxEqbJ){4TnE?YXUE0<$P7w68JzP z$H4(Jw=_aKxp^he9o;!T4~F!SXN6Qso|z5WZ7*(jsw~9--fi05G8AJHXQG%_zCkEP za{CA@Low$AkM%?uQ93QUgm4;=6(#CyiELK|yoPXU;pHIAW|W^p!nqeZG`ccCd4+^? zy}~RqlM+sby;Uz`m2mdJH*as(_u&MDlghNiu5YLa3wdJw_&!WM7G9HjB>$B4>c^i# zdmW491($u5-({wK3&lYdrw+XL2+P#10@0KDY?H|4KH%kxSFVDIOs0;Ks z_cleGA;Bkcmb_xc4xee6L_h9LD|WDOA=CN-ZVG_UNN#^9K!Q?HJoQ`4v@jXkE(Jl2 z0qgibAVK1WoN64gNFTN7S)3pCvj%8n)+r<;+^^)sxoHp%3XZ^;Jx!kcTrsn^0|pR5 z3xOg{{zjo|hr=HL?F_t(Rhs01N-(n&9MYur_c`TT+QhUhN;^@8MVZ8zSkyHq3Vld! zA1!5A)L#KReMAHiWsxAn(T^x3_Si&-4e)Xx1I3@c1X^aYMDM znJ`<9f^A*fqiR`~WJ}Df_1l`sxNuo9`j~9!+O;ewQ-Q)FVt6+1Jd;-^vFFJw@MO;5 zDMro^yttTylfVY4(>T?EZQq?(*?*Xb;<3c)h1WeHP?{@153&q^!1J7w;&?fNb+V8?(dkN4Rx*vc9+Zd%Q3D7H)6jNzpe0 zwhTafDNpl44UIv_Nd<+c53BAQ`o6J^KkSa ziHfMtJx0atNxM@UFnTwBCps9>UK7W&S=4k_b4hg~-Q@_Nx3SyW;#6$&1d#Cg#rnnHO1u_cvu9a}WUv{Ga@gZeq>`236{@Jvj@h%x+Kq zGvvJ43v4C!qXM0g(OCx)mG4n|YvuXhvE@Kmj)-O4nKOjnFqmt|MG zPm)|tI6Hl2bs~BfQYxR8yI)7*h-$^EKOFuW@s$mu2`qDU|rdyvbO3 z|Jmuqkwo;TI5m%qM^)afj}!qWP9D&lOrDwFFP^9G7wfyP`d%;IU?nslhAji~ezAG3 zHya<;=rtKc4+77eKe)fpN*-ABT=Dp8%yY$p35)}!0u&-80t*_tDTyjS6oqDf+VAH@ zF1irLiKaiyi_on_#D(Xsad(nJ(?_0$Xx`9EpLHsHxjhRJ)U9?lU*fIf4BF>g$2q9o zXuXLD_P#cZ*1c`iArkBNKd*1rPA(NJ39`a(*4{KA17@EYhPCM0g=$jZfWH+OBaX;E za3e<^r@bHNSzdwoJ`^M^lzxPECk{$TV+PmhV}AG;Q7Dhlz8*S^c`w><551j=`9BOe zr++Tp*Q~ksfy-8)6^>|wVA!h{XIq^(U#x{=*!4Xf7hoJJ5J7egR?Nv6@q@?D7xGFp zj_}<3nRREUm)C-hr%*XN{{;M#;y-G^V?ylr$>jLIv*9JmD;HGzRCtpiM%IXmHFRqZ zArRbZcZ!Vgb-%=Z-7FZJsGA>q(`>SW2cC;Iy!f3H-+{O=n<7&Cb+fJgEK~dYP&>FB ziJmwV3fndyoxN$0dHjCe+Rs?t7V&QFqc;j)SC8-OhR<6tjDuVl;!!2lF*+!M^HFxu z8v&)t3+?`5_XHMu7%oS!2EGI^$XW|xeFDT=Z=XxX^9WdRL8)dfgrEiH1K1&H#R&sl zLM36w?~Q*6Pp)srZRq$QItO~jd*|8sfcPQ&GYb3)j#^yx5r&-)>pA#%Cz@jaQLH<_ zL3xvdT*k#>fX60SG(~OMYkhRmXpWU!95@6ugByn??_g zpw2_{B&Zh1e!#P0;8y9RMJw(R0V$o#sN=qVGU2Ukcf6IY7)Ho0i>;_M!c%688z>`T z>?RY@`#JaUX2tm}lwJ0#?81f2ROk<#=$BKrezbSBtzQn0lkY|-1HM{s@0%m(tQHJR zmpYKb&jb9NPuO7k5xB(&1c;-%kpIXyFbWbH!7emtXQhCKPcJA9XnyaUW(&&{ipT>rsQ>3EY5A4gr_TkxdpZg1OFb@M%4`=d}|EA%@L`wkO)jKrb0 z`nOI6!)hnYpwqZor6emAUgP0Lsw8kTf*k8cGKT#M>v8he_8d zjDa`e^ew)qf*rl1@y1RkXuTU1d6nOED?h2cF_f7Z(xCLJ8}CAa!#!m2wlTk3`7OVo7En$lqCe(v`rKRfmY>Xq<3LaW zoQ64pcFfm58n8!&?fW}ReNAWWiVMznKJh4tPxoCMpf(`$sc6+_uf>pIVMrR1o9w6o zevoHd4u!%OlYWVTY5;j*b$!0Y$pGS9)Qvw7u+Zs+1fDO3CeCL!Ktx1>sR+HBl#mFS zVB73#!h4?sZ5%J?JX!&LJbBR?_a|#`Bp#%&;BTG%=u+;#VSl@fgweq3DOAV$4WFp=F!=SDo>Qg_PQK3n=vh193BI_Pn zH+<-w2-$-QUA!N0KJHChWL zl85?z1Dzb|$7A^Ecn=9ZbCj_U3`xJNtjdL|FOhDstOE}Syc}z4!hHzm7b>~BqHOe6 zQKPc)_x0M&dJy4qlp&){cr*P@B%lKJ~@B*E;Tht+;5#g)0oZ90A^yUDjYoSGzyW z-H3xAp)pOe2^~|%Z!N}gmxotU@5VLJJlczQ>d*=e>Zk@^$O$NOZ|Yh!2*TS6hlJN- z2#=CicZljpsfKpp!?5V*(R^hniM$x3k37Vo;f09H#h1;!|B+|_nG9=)dsO0Vi%5Sf zY0g^NK-v7u7+qdo`V`#DsxH`dS=EL7sLslU5IXwNqcDlfrBKVxWE;oZCNw~l$!*N8 zZWJ-=8Td$j5xc7^V0Ywg_dYBXva;4kZ5I}>lwO0^tr2rBD)c$A#+|{}#Eu14LJRF! zFp9IFnQ8}e*!y?tAzL7aM@@-{8h~~V|A;yxN(mod7!B}qlfe%Ts)`uqMBy{qJblE4 zw|r0`Yup>WhqL7()?JG~D{ENsN8cr0wptrhzs*!n+AriV8HkVb%vYkcA$Rd0Px}dm z0vTdd4lDWghw^KLFN63C;k2#G z7PgI25K4>H3^(~9f08l~Glh}F=#b5n$Ye4&o?HuDSP7#msR<^(O_|(bNAkip4{%p6 z-2V#_`Uk8kU5zRu6HnqIwr;ZeTsap_Wv**<@Qy+HBV2iMB&5o3I_qzD(jPnE$De}= z#8!6>C>Vx1=qeBj_U#5dT)e%AhzNHgn7_hTfL_J8lHPi!UER6DV`)!1>4nQ5oF})g zDt|sNLhD@m$deEQUc&^e^=}mCtP|kmE`1H6y7nZ|22IWW(-xtLnx};C!gVGnEix^2 z>#0CjIao%j%+uJfpt|%GsV>5y^HrCk??vuB9K6=m&me^)hrCaiQ9*&q9VjT++{&{M z+qDQ5;`8e;GL@i2dFb7$-uk^Vd{Yo#ZzFG43s?G>ulx*1R8#R&Peef>;0=b~;Muit z9LbXWSc+Z1$%8?u%k(6K4zmbBF;rOrI>G8u4=;T5HUwVAGQ-}~neg#y2^>CjNQpp} zAXh(`ghOUF28$}tQi~w+)xqJ<7llMU;tF<1i=d?fEAE&jaSb;7*LLgTRaV^5_w!3g zJo>Q-e6^Qw0%0Q+R_>8bD9W*b*8kK>IVZx$oUg(+`GScfi(4Rm2McJ884bG!!iJ3a za~s;C`18o30|)HWLCUzjbDETQCDv!Wn*?ozx^Kq6ed@p_U#E7lALB7l98wWA_8s2h zPd47arDBEf3S%3%m$V{lIu@$;kjLaNR(M+v&#zUb-i(2VNY7~pEsuh1AZ>EfK$nd? zBbL`s3gQ`An3(A0C;iOgMqfALyan9}-t;x>M&2C@o2@ZrcJm1WG%X^Vil>M*mwoMq z1fCV}_m4;T?iio3gx=5hEA7|+pdY#N5-Fl#4zSVKk1-~0#F5RB6RIkOcgMnf5LU=- zHOk<9?g)qvl6?6|bPPGqY!GpQD7Q8w%595ilG;_=HG?4Oeghx2@RT^scTw_TdPY;( z^Ax1ejJ6*T@MpBp^i2X^)s1)^P4(sAbu`W!omVE$F7rAX5<=^5SwUGhe~NX@A^fMstzo-B0Kq`KI8hZ~W33d8-#gk_e-FNmOHj@;ps=-IT8rUg z%1H849ku4X1=fM{1yE2C*E>7yepWcoUeGk{^9VwDXbV|MZO$5z$3P*aHpg^@vioC( z7bs`I%|^~bB{r;8*WXLBr?U5P@nv&Y;SNa{a7-jJ993LrAOi}zmS4j>z(+y&6yQo3 z!5~dU$33%|Q{`s7G*Z&KR2Nv6_DnO~KXZ>i-P!N-SvSGSU2)}eI^8#l)l^^yW2ytv z7YZ1%k^g~7YYA~z);iwb)PvNyrUq!5<*LbbCr`NKLL1r{o5J^)#aOF?q*?k3zK4rt z4teyNN_YZh0&t2{$Z0irTz1s&4qJ_~yM#vh`ajSr{j6w|(*hHi6V&!{J%#~9Us{Ht z;ugSEI0)pyKGCaf#PfQ{y7|tCysH(6Ga-v=VLi`@2qem;Tt#|TL?ElF`XbP_da{Pl zl*j9F z#&{V^zE)&y?*_e!s>Y0mY$W>9O<6CR+)rR`qdb*3Eg(dU;6DiyZoj9rheqdAe1u6XVgAV z7U(S)gyA9pVY*_zC4a#no@K}8X^|unx=4~AvvrHeNx}=8<${0>WS}3rPlwNZ;?X_#}rQ*xx-gCRyPLKQy=892j zxX4=Jhqh_(qKKZZP%_Q4P2Y+=jQpbzhL&@<9ENAhraNA{Tw0-|1tkm@9`cXZ*3bTU zEscX}whySY{H~4aUWafPLhSwpham>P0gN8hsma++;v~>M;Z~b{4j-$}Xp_UQMZRBC zeuu+1D1~-7&ilUZaGbQq?r=DWf%wJ*n3odboV5~8?voXQm89Pu>^rl!g=i_Y)No4% z#+LmKKGkDSe-v(q`mMO}Kd5|r;Z!^u5*u|aEDzThC-A#Mi5@ui;B-ycpK zuB=a}s_bo(7S=!MxH~A3=!w8Tj{x<)-<1}iZVIia6rez%MkcxC)meP1r2GaNlKCe))4ppu+!>Bf&?}^H{EbBy{ z#?`uDZ%$tI-He?m*`a|tHt9qkhmJN0R^#maHEymT{}44Sx$N&O+l#aFvg6V98!;jp z8IR}d|JSoNR~w#SEeSu9eohHR<8$99n7wk5AUoyBRfz792Q)5 zh7%BoZdToJn?iu)81Dh<#SZFp_Ef?%FmuWl$}G&BW>^k-8`Xk%XvWRwXul~fn8SY4 z;_r|wY0Z3z__DbJw??tP8K`GHfR({ui1|~tnXqFR4A--}<+idS{|FD}FmzQl(P`(< zrMEx_G!j4$cG0Yf4)camfU(J)58sS7Iodu1CuT<>I0?yp6qV~_TLIrLl6@3L$;mu= zCPx1!e;=ivl&(8?V&g4eeZkJitS@aZMGF&nL9477lW$5XG|F)oC9lKJ?iPxnuY(qW zj3xisIzm#~%Hk9MGm$cg-s!C^Gwe->4W`uIM93-=KzeA*<$2yY8Thv4HD4BAHn;6R zLcGRoo7{44Y*3zH| zoPSJ*r5RqHdL}&Zj;OZ*UOwE2*d};~=}oU}fwy11ICLf-yFn~&bm?a@(~>CTsN*Xy zB3%2sNF>*Zw%LC>9KZnlGFs?H1<=!gYex;HBdcJ5Oim z_}l^GAwI0Ej;ZWu{ zltT|bePG{-1{CygVd7i@vd=yxBBr1@r|_=@{wlrRbcXBbzoUr7Ap6^rW~8M zX>2DFj$l)^T)ndl!;W|EaZVPS0^w}27-Fi!F-b5hThPfXSS#6jO>PN6?!+?&EWotK z$7qA}v_5UpP1Q36pU8AmSDXgEUp#gQq(VlJFb`ZX4g zk$#zi`Ta@?d8Q;chCqUNjLAz0B(_tMY&$i{nx#{t+NrUiQ$jE7l<6_X>VR&|bF>ai>DuZ6Vg@ns3&bS4-%~zW&t@OJ^oo$aIE&(;3O`#s>fq zywVf6`Li_Muc?CmVb-IW*$rmS>jtj!3D(#4VUVOzc7Q1F^E=SWI^m2fm;ks7rY5;4TNiUDQ_M#U+ay??L_1G%LU@0l+Z;%ne%97E^%Ru2sKadxQlHw&^$6maO(xJPQi!aPwg| zr!2QiEx5pnso6qmd;Djh{~lJ2YoBy*?GujR5YOR)-2ipKe@a&%aeRT##cR~7F%H{> zeDbo(Dy8kv>ldk7jS0dz64S;U+ZZDGjU@Dh3F!s*5d@VGC|a%p&&}qJ`LS5hW!-!H zUNkIN%xhSdJTSwOjn-?U4MmMg*UL28f4?*;%W7UzvgYb**v0*;)u!r-nv#x}Y3dAZ zD#sN(uPGz$(J5}KTAQjVYD&6Wrl~vblU|J#HKhWi$dScOMYO4kyr$-1)TF!V1-+$4 zZJjnH;wZk|^oB6SClYgUyW`q!uBcr}DAVp=X}kSw*S02;u1{m=6gM@hO^p>b zB?)Dky7yk`Vo$g!+cD}}XrE4TYZ+~AB(F7&yd;zv`3>4yXSg-#Si8p1DQ;>|n;On* zimX8r%5?0>d!%EntT>yhwL}I{0X$4dAe-v9-aI6?C@ge}Vd+;`28v*jgfg&fQdpW5 zmgd4%@tp1%xZO-a)hMr%R8e{H=RO>Hf{rA|K5$kM8>l#z0PXLAiECcTl|eajH9VA; zy-4G(YiC&%E+5*e-k?=c)aKj0vjqlUd$To6)DW0n6@Jqqyk=89s1G|IwDWYr3m?7R zftRt&us8J?_;8yj4TmQLMc&2mASkPv+dBX+2E31s5rMO*VLv^c(eyz&I1&fPG}msu zX^GY4FuW87L+tEwDPQXv*SM<RQ=sNcC*yD;1O>{#n_7l3y@L5@<|aEEIF0H z!c#9Vg9V&e2(X|E1B_NOB8N^3<2s~eX<nP_1OC?;zu zK?{?71ftZ8zyT*83$pu!i6Kgo@&!JjG%a6XhCIH2x0yl=Atej}N+jhE!xzE~p;s7! zmm1Xc(tH7=3CZ%{_yU-3NkshmWn~b7gLE%4L_7m>cvTLz@>eP3nkb>!u>{{ zE(!&5z`@P;X}BJrsVLbmtO>SXw3xKv&bIxyRh#+5!NOtWiMYGE9**K8Saq5Q)&d$N z^7G)U0H=*s-JF4oq*;n}Seq4s2PQ5clxn!Cl$(4Ol&b5WnvWze-j59q>^rCGfi5Gd z)xt{v5nC5{8LN`o$?!o^I|UBkONhZ$5iRAw3-M`Er&t3+upRj6z0I0Ftm#QjuZClq ztASTXXo#@@59XD%ov5S-!9x)wi#S9A8(FNn)Jl<=nKh(a1+EKWi+g9t4wol8;e`CT zNMBJVy>V}eMf7X@2280%^c8k6Ay)c>^{ind7_72LF@rUzNMrZSV70@mgJqY`nb^cM z0_E4BNtEnA#BDpBUU<|n+m25GRb`|ne$cvP$Dxp!jwie|-3c$=DJQTJjeGIpsh1L3 zm5UwQ`$)FwGv~{;SEBKDK6A^@wq@}K72cYN_t-b4^h3Nqce?gQ_x%U=aX!%}TRZU# zctm}qZ3!}S4-yAKPmO1;InoBPe__ve0*}JU`k+wCckxzDT!#6%mP}%zMHSd^R)vpSwz8qDvS2z8G_G%an(13a} zxDy(QS&Q!y39GI1pgD_KbIADmF{*~~8BtU%sj8wDsi66D1q@mNcjX&^a`HK!KJX2St;tB+=|EYMBaH`>hG_rsD_iQM z&n26u3CF%|hJDR_zckOWqkL1O4ZF7SCX`RDf>mPQ5n|QQKvrIV1FVtIb+xXo%^0dr zvj<+h8E-Y=%kx#5lQ^FETqtGUmdfCL!hIjN1?F#gc~Bsf;XSjXr1!D~HLM(mr3M|; zF#sgjp*?xA4q5iSB&ga+_jbdo-j_8Ib;V5z+N^)X(2J=>>1Z>`oz_fHot_iQ-Pqc3Lj*q%0kL3R0aRF@SmL5!#-- z-a$HeRRnKaNqxx!LsN)a?LM}e8*Wb|-1`&mFLK}fIF6#=`U~-ZWSyZWXIv=*>Yqdt z(mX7xftRr=B|HTmCd;4T%=e^_ERxtW!jTZ%_s6rK>;mE?W)%{#~&rN?yOnmW5JF>Sy*#Pvel(-Ub9!W2{KJ3Y~74kUX-f z3X=kF4lwZtZv?SKox9yZq?h8~*$aKAqog5~bqkdbe)03d2UC4)Rqa@zIV?-W_wgmr z!wdmoD%VLRn92`$y`*5DoRvwW~Emiz-4D8tNx{u}Q9>W(`gK7Lm#- zkT$8IR+Y1I8cJ$tTthJpjcKS}L!%n1)zFBBA{xqQXq-k_oMh3En7d&d){vN^VWiiP zSd6hDt0A%3!g`<~-Th4Um^5vnTSKE7>eP@Zu=wtXhI+L177Yz*&SnjbYp6*>F`^aw zY8oP6MJT4B9?jXHA+wm&Yp73iRwJa}{dQB!foV_p61Itnbx7U{$JC<|s@D1@H8iX> z-de4`zX7yq`KIvMbjJq|+(NVOnVcqIePlI2butI#fvE2vF~W`{MD)KIfF=V+)? zLop5M?qjM!Lp3@K^%|PQN)FiSG&H86S`CeBs76CM4OMGMk6xrA8mcxVzfT~m)zGAd z#GLJ>avG}Bv~dYRFafUBTMO?9y=gs^(UoaI%wS%OgP7sGm^#E{@?z={GZu=$Bvlw? zrND-&gs>lv4S)6az&l8Gz~$6j-7Vm_sF{G-b3O{O941hRWs6>$ zwVU24Y1TjfAVUD}$ z_u)^F?1W0+c`cIv1AqMF!3Ie-fDYFOp@i327la(Iua+TqdkzQU{o*|};Vj+Nk|jME zWJ!1f6^Ml0Ya|@m6A8*CyzVL0e2A@t*N4}eEPx5GKZj7ly&)46cf8JVX2F!s!}6F$ z*5*axffwei&x;(<$aYSCe~>6uA!k#NGvN&nGE%c7yupDW1R(mgKxr|5Ih+T0jYbaUMOJGh?@$DIuF%Mapg(|f3Ty%W9>~inm%Shn z^Y>tu-^qGn|%EiWExe{u1^Gd*HBi{DnNnJK6!KES{pT^zk|RDk>SY|=?N4WnH1h4-GL%oCWo}n zK#>W$A0PwWBVcK*y$1XV%Ig6pp=2Ofzm^sSteyWWx%Vxi4p7p<@>PO)7B(J)OXDI_ zw_{`+sZe?GGZ))3;t5%&N~GUikYWYNnw#I;)|v=+B=D#8i6znsbH^iV&>o9pWkGUv ztKFNin|JJ{H?gi*gGD!j8dU~$iF|TrlzObuoIuq$mZ4?5JluK=DouTwHM`YEvx;-k zq!T;mm2KNv#dX26brn0`3+ zw}r_1%To#p+PTjzMtK{Ltpem`r=%k_^ zMK#O58f_V%FoCIVl!NRT(W0TW)b&urWf33COHembaZj8X51om-WR}Kw@PYw9_j1XN zJ&~!)*nnF-fMZyaWj9WCJYmHk#h_p-3;qZNQ%3=GSi`752oPc$ce)x$i|#?C#whY? zc=fd`=?pBl8A&~5La|-t8JSlejVAVG6RqoZ0Jg&ww&Xe#+?}vpkMp3=d(oTZ*hAc) zWcjH%fv%(*XJcyG#{wysuM_zKme|w*=s?Q=>7*bWJNb*WxUWLPpvNvwUoa4IY7^F~ zt$H-P`q3{4M=5h67ueHisz3)U)&5H{2%kI=bs|Gir>S4rH5$iNTW{9JA5DIF3GS^F zt^rN99gKRtx66M&pAg6fR4~R8sbyd}e*8h%Nz_7IFB?DtI|nXRUe+10OQuRYbZ~iu zS09SXgMdQ3pahm|7`I{~eK0nRM`8hwBmN^(nPGG62|U4K`Fs4(yg$ZQX21c0v>?ChR)C6*Yf?L{hv&9Gouo5N!+_VT*di_L5qvcfJ@0tyv$73g8B`p#+K=f%4hVZCtxdf zi|p&f^)h!J1IS0Bz>Am1w1&%PF2DLPd_AGkjA@zx4a}&S;N|EY><7EH;7p3t1+PLz zt!OIRb$XF4 zKJf%xxywUdN=-47%>DBRfz4cL$%*x|LY&Is7JfQjc!ifgUkw#mC8uafu(`knmkDcx zABK=Q12yu~SHT}%%2)MTc=aa$D-M9?oEddw?dElxZ^K3G%S~;- z)dmddXvb8a8V2~%5I4``;&9;y5s~}T)trtUa5Kzz0_%WaSy6)4h*M4%^3BTs;LK2i zU7db)?Tuho_`z7$N%O4O!Y_4!`q}f2!;S9`E~DV$K?)n>>B;0(&!G@5(zbe5DBOA& z>^dqpCZ)Me3Af%wcPNxVL1c$4kak$?Bb+6l*vCvo5s3vGf8e}9hjd!#C{g6p==TDB zQ)b5Y9AF1#SrMTZE|(bf=^3 zb_$(#BxLMkL-N+gZ=hlQ7UMVSc%_i0QA~RA4cJW`UOfi)WUX_f=IzqFuGVt{>+#x< zZ=f%JCi$a%Ikf=M!Z6yG;U&4xrP-tXJUoMtN((V|;IZ08TcYk4NYm7TIKkm@GMbU6 z2dR=ICF5P9Bw_!}hU90X?(q!D+k$GTT5%3O8%?Kb***yWwC@uY$_Im@Ah8Z!RRpFl z5SAGz=8t<&rMd*F9t*F&S0dP4q1^yOKDuvpkl+egmPA+=?#`$M^Xk4MrD%@5V4|)DTBddyaJru{*j$1=SE!c#}Hz zHvyedL1$OJqSGpP(3lxc1Y+QVAgg{{0~6~;3635f+wsT|!egiZ$W&(799xSgXwF^u zq2}DnS7wiQ^y3jJJvPOijmEkJCPL{u=V=^*9ST&@%p%Ok496K%+rL1e7&3mS0*^fS}=!K z-$Ifw_JbxapP%Z2oQibq!17s^7jE^BS?~cAOr5DtVcH}(;X=Fo5oagzu-D<{w`zfy z&pB?=YxC55m|YOQo#pukfi}{^Awq!4Y~IqW7UJN-x26$2LKfaoA|i}K#WBJWt{9^f zuIkLSCpL8rKFFFhb%kUx;_tsHc*}vaD1v+H*8+E2p@E}@_imjXE~&i-Vzh92ZD<74 zHiVSvIOUzqT#9)bUk+uasR_AV1LvcpPSfPwqM>p2VlxEh(6U{5bV}+u;Qna0a5phr zprXQ!qtALuk3ex9S|=3uT>~gqa;V(uN3Ow;Rv{rn`5Ra)OctPDG26k~5hXdf)mYdW3HzzNc0KJ%gdtEG@T0%WcF_$grs#5jtA#-7r$XvS^_;h|4Q* zxXF4I=vXsix+*Ce_zENg!AS_#d;W?RA+*u35qv%VBU4rIt-})}^^N%9F1zJ~!ZFJS zG2mmaw((iv*iB&X)V1XCj0mjor5E!P8H<;Erq_ciOdwV`Hiy{`U=98<&BkAaV^jI{ z=YTgYda7wbyo)v_&!W*&hse}J4XrlIswgVzl zmWH~mT~trRhub`u^zg`koZIk7RHhpF?scl^(3}xt%R5EUQ4QByr^cqCtVE5acJiKH zg;3D6=P4fi$h8#3g^W!KZt-pOm%($*C-xw95uSc2X(!>yi<9#r>Q?TiU#pl;N*us^ zh&Mw|SPqZH{v%VBRHoty>!NA+@ks?3g93sPjt@Z=r~2`yju$Xq$~U^_au7p2!jFgW zW9(iST=@1fAPMoDoCmT=YZ%{B8zci&!dFBopmE>QnF6sPxli1;o){WNqF(X0jFp^@ zKPV-OSimfVmyEp}j(wJ2|BTN2gqOrQ3R#4A?el2Xt**M7^z-c1Dts+V;_;eW6vY6Dm$QK4UyeZ7$qcX&-Ip18aSjsKIx*?M2`q&W>n;y^=B&5s3IE zwE7{XRfC5-wE94Y(5hMSTb#un2el|&a+1}j&EC^`(o%p{SL0o2wG~fFs|WLmolbq! zODn)r2Cd>`G+@&=Mnfk`+KIp@#A_i6zF!q0|ldq(r`wnflRN{sRlledP`4 z1eOIBGM@l)BA#Zi2S^2}Y8J7`^+p40qtt%K}PN;strFCD_!F4p&G6)^J4kJfEP5ns_075dywAv%6djD)p|%3f)^7DLt^m>e#}zwHZI`g% z^(dICW-KTy62ueHX%RC)cZAH6D1dS!wj9&~Jn|n>hw;c^NX_B9*U>y=c22vHSubn! z@`hvS^S+YVA3+BC^gEJ^$k!MeDoDX)XvhrKBtvEk_{3hNPQa52LYd?H1<*iry%mJh znNLdWf+t|Ou^ouI^Ky&fpvz{UoH}A~0jW6CDa+}rP(>C?9vDB2SBVSzO6%u<9-Qvy zP`?hBK6Vtu(J9N%v>Lqc!4`AX=KDzD|Gykv>9t)^Peos&_94xXnr6Al?Wx$gJynl+ z+c(ktTiby8>WKy8Arp_l!T&*4_*XXp8Mw#(^-Vwoar-8qyBAm!&>iwLn7rw<2~0o_ zEX+0maRK-+(z7{aLWiYszp9T^{FP_E4`Snd{0aCgVW1Nm4(x9*>686oT`ITi44)NQ z9*ngq&3kFNn&+0frI0-E&CaX@jPT9gC-&5qcI=G~@X~5Ut&U8t^xd*QQY>%jK z%?gMHDW2gGO|N@W9#M$Hxd;bOu0sHdCyt1LY-Ee$byJ$;3!*A7jwY0R6E+o;Q^a^s z@?CWqpuQbYdp_OManwNS;*vZ*-Oubq?vM16n7#^1ga8f>kH*L3GfH=YG-&%kAMXK4 zRN}EVv;|fWF>IvSv4A+*v0yim#->vl5qpYlJ&IG%Pu@UZeks5p-4x*WtndjN&kCPN zlb0Ne>QfFp;@ALpNE-Q(R7?mA`*Zmz(w|r(W?Q~rY~H&u-wnp7qH#KPIvDMX?{cy& z8;Zgv=E!$M0@FSg@2bHMHojEKPhSOoSOAkbei62ccR+@CX7hoh&kx0t|AqqjxpADz zWn7UH?;GQro&10f#C4{nlp`g{6jwTcw-QuC^x?5o9@XSh#BL+4Jdoxz!?4W6dL;VW zE7*eiQe=C@m1_`IcW)b15}X^w((y>|_Av}*gqGL(ebhCn%)%h|Y?m09U z7iG~xstyjgpPYdxXc2ZvI`p%w+sL3_&~0%!IE55gMPK?N39fty2jG7tkvt7}F_+;K z)!_?mqIeHj;R{k-qQ~{sV7N`l$qR^j5vP9cAgdMG!3ix%xZgj9ir^kvqI#jOZ{bTV z^#}wnCEiPWJw_b6!MhP41TnIrA5M4Hz#W|+7uwAbEi|t#z5%;A>1~g{#@(DxBQ#Sk zGxK7zuFnw-fKcE?V}5VGl$`}iv7ETBQlsh%!e!)aV*&(AQ?Fvb%5(S2?+Uts?0!Lr z1@j`EG@WBL_BNM52j^{T>fP4V&A6yn=W-o3?VOVsUhoih^IX=5&brlC;U_tFtGGey zJ!4|qQQSFVTT*z@tGCDB73(MM1^ivgvdx;>h9CZe!=KJTpXw(HdqaS%?@8sN1C>yA z;c>)&WU87Y^18O%apXbAML?Ty2KRGF@!W_}Ih0o^kS6F782*1HZHZ$p!SXCY$J|bN zVj9kZ-A7^?vb|p#@Y^X@ZUylVuUKybRiek>75kw)4JNN?R5vaxe39Ox<1@AZashx* z3umIMxrT6y!NT8zrtDxpk-E~h`l@vZ`y?gM59lP39`xmz6WAAAz%cW1JS87GDNDE0 zrIXJ`yr)K7J7!kV*@g3AF=(3e;n<1U^Wj|(1esWHmu!P2>GIt)NJ2+aNnBX+gXEazOrv5R=a1wlzV>6nz{6Q;#T~B6Nxy#ocN9aj4vx`~ar=i2PLV zji2Nxn3f=I>U|2I#KI}4+5~2Es1yajxG$C7wKKcj#|cL`profHI&X6K8*|UXBQ2I8e z#@KRsQ*A2VRf0EY6UFk=SD-m%YZJ`2n1_S9MH25oAvQj0wo)=6Rv4VFaRQ>gCG<`9 z6JcYhsiG9vAs%}5tL%=!wjX^XK2c9M-k`-*q8{uUYnQhhYUJ&PHqB{dMYFz1h!yrc z>zk!6fEP>duxxZmaH$>E~{IE)~@9 zIOtfJVoBk$N>C#bTegO9&ldNX64HPY^xdyR3EFfq^n4k?xJ-^ftw0zDu#Pql-3X7; zR6Np+M`GWom7%#E$$$g@j%}hEsI#nH94T#~8D3SQ{Z@H?s98m%V>qQte;jzR~ z*scydPm#eYZ{kprUx!!I#rdyqNBG|sO7e|kIngkbGs#)_PH7 z14=A5Sv*R6{v^XlFr@|D@YY8?K^Vyv+OXZ~*S~=&VZk^2)wJ1>V_f@FD;=|?z-WKs z;7809iY8d}X%tOe^Z@IUb7v@~{dF&W@vl-I$VZ;9@_Yi4&v@zY)nCX2NR38X4)7g7DI}{3VpSRTp3~&BrBf;m-hsaSMA2K%7h6>b(i!B^PFOF3)x& zEK!f=wCz^^5$CHUi&@k6@AshZO^5yh#tOjx&8+{C-A3PHP65Fck&TT&j62)7gaxlh z!BjQdz?mW}Akhl4UP812ml-mXXbc0V7~E`CAv0@j)ng`T;V?uOz%H>Xq7~>=;K~Uk zB`f-V;%tl|5u*>9F&GN&MR|t4`+&|-;FR`LbBRYe?opRcX(q-Tf0I%>Muu=9nf(F&tNV+~wdo)yQB%Kw1YPwDre;HO( zNWW`+=_ghGV}s}V%osAp=pNt^f>&3vnZa|2%g8P9JRrBA(_A$CJ?e6vfVtez2`_2D z90qP2bM_GNK4HLI$6PDr9C;c{HrL`xER3BjMJd^Sa!j^lLk7?Yh%EJON}+$0hV%^K4m`+b4~}gawzV&}SSiDm3Xzzi2ODO@Y>J zyjOIBL5xDJ3MJsoPQ(jWXJ%i5>>2wjuuI|)?62^4Npy^7tVhHpGX*z_qiBVQ-}6Ee zJ|#OQI-z3CR+T>kwB@1Lw(#W}VD`dTEQEIJHIcqgLVMDZKoi4&SDMJ$CV{0^X5UFk zv4e5}i}VUf?^upzskOar>viQU6MmSsUN2K&b$4*R-cD=qgzNQkmde_LaQjkOuS4^s z{~PGj5tiL!98z|U!WLV&L8?=-wuA)t2bxVFu3*INBf@6G76rXq%u=)KkLNa!A%p|z zNn_AlevTK~r{Zu-XYNh738Kl{8M1V~eVh`Gop2AyulhPfeJ6{~&zgI;8#DNyEVv2< zQyx~ewzZ$?XUK~cuXmb~B$UFaa&RxWNqs;jMCNNPZK}+%&%VNV>kFT6M8?$%I^P$x3 zZ=h~ZR5CUZCZLI96YrPU#5+`kZNN3a5XeRQehwnUk4^jxs;$EezxryNAR}grl*_YZ zCJL=ZHB*P_HaZ_+lTh)FokW4c;iKKdcNM?Z$0d7Lh0r{&wxRMG&;pFNN}Iqn=c0n( zKswlm^X1jrMbTO7Bk669ygrk03jc_$$``;XkbLZ`J3!$OgVZ6bS#aSJknpRC?TlHP z@;W;Ct;$jH3zZc8`AD640_6VIoKOR@e9g65nT!+aDu6+w+c)t0cR8VU)BbqIsMn5= z{)w|`A}7=cY!=qa^c;;E@vdR~z-%-mKYa=OfI&PbR4?9vG)xlaLn)*U%|D%z|Auz? zxv>pD(YPWfKG4iJJCTajW=UEKtv1V<;#p<7<-3?edjeUlRi;0X<~gCZAklY1v4w#B z<=Hb~f0^?Yh)E|VHNw#14}Ly3pD~!6caKiE-sabwK0#UWK~Sm_Y9hk$8=iy{3dUZe z9R=3G0VkAd>DcI;&j}@8P)X1U^%R^mz7y(+bA2b&5WeJcLVbnPm-99_p=vN!)9fR< zjMe*g$O*+7w&R3a@L{O(I8xNJnzg+hPN>^HD_oV^33YhxewBE`H#sL1tC^G&>e<7s z6RPMlG>cd7fuH22N8fQmam^paWuKgp|ItpUKm4aCwcw0qZ7#Tw5z|2~C)7s|<4TiG zsD0&WF!}D!{JT1#PCb-;p%bbBPszIKEW@Cn!PvzZ0+Qbe)dHI4eE4PjX3mFi!3kBF zCS&Mjw4#*DGdQ6nLvANj4?069RCASeLVb@Nb!YMeoKV-vPxW{3lN?!*<%IGgj?$Vm ze#xBLw6$dIkP~W8kPm0yM)Z{G@D%etu@h5Cse<@StnFC-k?o%%1>Xr<}^;IHoOIOi{*G1-C|6$m5NFoYt%O} z9m0X8Z^j7~#T%=zT1bt4HBP8XeKSs|3cUGFs4{u8PN-7NDasr|VD!y6p^Ej*GB(Z@ z4r(8w&Wxv}P@O4|LgIuf50fy-uJKK^+YS~*b^|C`Etfp$tLF}1C)nOz=C|sE zy5KZS36CwzTK^g!%G8SdPN>6Jbirv@0l#t!<-eP>Zo74|PAD-B-}f_X98TZ~6GR0y&3x9_G~@6klPC}{4lk7K|1jgQMwO!jauhcr znAECn{4XQ=CO#a5J?Wct6}}mLqbmujWJ2E>i3TW^c!SQ~BR_rJ`pxL&cfP~Vo|EvS_*)UU<*wNc*+^sQds)aYIG7)u;Y@eB{a z2zyu|eCsY=FmQq6IEl`*<2YZ!>HT^f=eza?((m3EGlkeVnG;U0Hg1HcX9NUdX#LH5Jtphv3yAAf7_D9r$aA33FfN}QI3vyXmh`mMhw#hP^!NT{WBoD&$qheR0 zc6i2HL*!hy`aHO{lfP}qMN@e~i9l0AJ1BfG3pbt!HSSh%Q+9~#ar7L2cnUz)ARz3U zS9+>ll-%y&V!DMn5U|ce!;%;(u@z3@a4}ZE$e~pzkot;n_+YXS9ZVl`>dYlx=T7bkA$UReAXh_xItQbTt&3ZN2(F{ zENah55=6+%lc_WKE*jkrBur(FQ92bS7o3hvic5|B80~LI?xHy%V0{1rN!y>s`(ZN$9om8{_m_{rF_wq z&wu}&h3)o_Ce+P?oG7*vU5S|_w<+&`BDyj+bTU0@bmbrdaWDrC$@DVOafF{PvkTjg z%hO=;1N&txY->O8PhHr`gkV{R^OA6hBmAQJRN6fDCz&ZGadhEB(=^=iOek!0)^vmS zpiLDun0GpFviAos(GaahA~xQ&7;jjU@mwL?Y1b&<^fFE?n(!uTvSxnuw%Jt3oAq#% zYY`E**ubK1cDkdNAq(Y2LzTITC$e z1=|cPe3IC~pS-G8)E}u4*RTO;uJLr)J1cN@>TKBwYdi^m@rC0AK^+p3ZI>YVVlWmB zLx|$gu%Wb#Don&a{KG3OSMDShDkCQmquroeStU+)@NGHTG<&P3#&VbgOl>SkSDWyl zUR3zDtaWm%b8O41pmuGa?Q8b3Y=4M64JJRjPe_&@3--?Bc51$s2(fS}?dOsOEM{Hz4>;9EhY+U{BtCA|aJWd}3hd=npuit#5HPZQEXuXx@m?O3#wE+BCI?aj@K0*z zHLJ-T^pZ&5dA;?$Ht3~9yY*gn>%rS>w=C9Amz|pf^!)k)VIo_D7(Hr)fh3649$q6i zOx$m_d|r>ng5LHu=A8mPGs+I4aS3}Bk1gin#1a2GToYm#(-{D6d%Ro!db4JuXSZIG z*_U{Xhc03)jB`DzZwcM+S%WvodrlG9R$0Nf_&~Y*^p$B&W40^Bn@kbQHMvw~m6#m; zg$f=o4?X(^m)x|!nYiWjPed>7aHa4@TNtrxJ1-o#X_9hL^|Y*Zp?5&F|B1E0N# zX$cbjiHQ&fCZ?A-F};Rk)^H&%@_9~lfkmC@QYk#=Ui4Y48YUNy5P9s1VSXOQD5`p% zt(td20(xHZXLqy)Fs)YvcZTKNoursu#9O_|0s!c*x<9jwye*`{1x40T-`N|Kc#Nyr zp6N@Hw`Ug2eZcqI;2tu)=U%EU=^)GVwHw|}rGocl&aQ>S z9?|KXn)(s;VL-OnB{=BApMk9<1GWxPiFeo={+uvv^x_WOWT#~n@i8gmWJsU-LW?k1xUG%F*5|D0k;oagVJ@rT#5;Q8oHYH9$aw7B-vWgH(`sbmq)J)^o25|CTt z%#qCU)^?pP<@DrM57q#X{dc4X#@oJ{1#dyY)X`U-HG;jblODdkL7l1j?dY&wDF!!t(D!2l`Dp8W;|1FM+QjB}BMRXevnw{@ zvI5-Q!+Bh`g-wN}<~%0p%;;Gfp@(tZBg2go&#PF6>~WH6esTE@Kn}nQv@D-eD^WIi z-e<7DY8e>9M1~8hK#~*yy(A18yPp+l?w#QpbM<}9e*cudx042$|1s2y@}l?f{U`cv z>T9|f-%Q!2lkm)KU?|sg0G@3ft$)x1MdTd@@aY5)*FqqxK)q2vOHq8@S}mXX%Fm;H zwh4TDM8B~``R3xAfP!zo&~JQ|YEP%mV<5-pYxMIH`}x!QS%AX9|NB^gk#&h?^#FW> z3WYoKQzfE&9~b6N^$+kS7Te?%hs%nVK%whWlRTrQ52wSMx=w4lL#jBqSZlh(tLZ4M zNibn*l4sQP1V0T5ex-M!HM%oDt2O;{4}s}aucp5pCNL2h7AAQ{O;>77e3hF1B0_!U zJyONNOSPtIuclkICXy2aY(WF9>w+p8T(3^S9H%UKHZsQVPVR^5^(MptCZM$Q8#@Xyu-x zq4t(Yb7)T0navm7lR8&P*Xp5klevu{b8ThSDc*&ZP4_|ls+8d$=%?!@{yLkbVui+` z6u~+d*e#Ad|M}E8u{juk%cxU19p(H9ZFC~$%E1bK2X!f2#>-MNV_4e6OgsjwL$3;r z&5)#(5JH@Dx|!q*$X&}Jm~-7>CdjQUo8gPGR@`5&)CjSAPf?IjV<}R*DM8|0J^XQ^Wk|(x!R^)5eo3u|9j~SW zntno3JBB3H{Al7VbYj?UJq>!8c#lOHPO~RhOhpxB^3+w|L}PCCl4+d3(WfAzHS(L+ zgZi`{D06o4>}bGhd$3TT>RPO+wg*czb-AQ^J!qEHjy6d(KXR&dbiy7iz;eX)fIy^v zc8T=hrm392***9_ErT!PH?Ifq?L(m3F<>TOdz?Rh4+;dTu3~}88-o%}E!ETtj0|Yi zEz{I;O|3y{6sZ-OS}CbD^+0ruJa*`h987PzsBsQbfYTn0#0OYJhEx@N$z+AC>=5+?$l3WMpb$^4$^f`&QSOH zNi}%KMMF4z01%r)@CtG9P$Hyfs%MCj)az(eg9~23Q}T{ak!q{2MC5t$Z=b}o?O#nL zDn>BO0g<8brRTxSgIwn@*VQP2PeotdMT~}#p=1+MlHK@oIBuW(D6%FOu~x4pOFea{ zAIj0r_&5>uJOO4;ryiVIBI;3W4*H1Q^bn+YaO9P{H$d-V=OnAt;!qT)s{&7$x=Vc^ z>M>q$c{!2Js*O!$Em9WOk+Vjad-3-$sq~^Br+x=oi8>8Eut1UuP$If$B)g41Z9^_A z(&2%KM;nE0h~TN^qUZ0X>e_fyTP<`Wq3XHr=Q62UuAG=ga6x9DKQI?nlPR1&A!;7= z<8%pO!vPN8IO&Vm!{7sysdCX@YOA)cT$G2_>*xefTL0m`xoQ1S00H7Kv>yJ}8qgTu zErEA}z)dvH5fZ9lXuQ%NDA2fQVK^W02nO9Ga5!{D*5|21ND7iX6dkN1tI?&**)zo} zCzRwLCdqGxK^eq+R|SZ9H$HoW>XZDk>B!N=96iX98l>b%%N7{|%fj>-pgb(~*$p9! z5TTyp7ZJ*6*n}gwMt>+Wg^TF-=n}#Z4;wFfU!gEnLFx_-*9m;f(PEI+r)JW+w3hlD z>hT&}%-V>6i%}si|i#y8Z8*UOW9)PN$254a1&>;~Udb%8)`+yI+da zX?uSOL8NmkH1tb83&TZUc{%#!L`ihkrYKmkC9w;*eJ7GIinMt(G!L_^(|}3tQQk5V z-<%8|@aDEal_Qg@ve~aPp;b0VdBpMKs4^OVFnPx(-h?5>3>jK9;|~XhY5?(%i3~sD z;}gqpUX+|J!}rIT!Lr0nhyXts_;I8itU=x*YuE(DF_WtziHn{|y#_C*xh>pj>K8_H zRv|KqMD3!dj9Re;^`VrQ;U(hIrbc$ zpjP}p{7|hJ=c{HfP^ty>brn;nWGEM7rV3Fm(0pnP6;ccj;f5xR|1iFz!V&zieHF8Y zP6mX45T7QD3GE`h`Ye{l@|LA6&XGV3ieKZv`MKe zn~4QyPX;?KqPC&Q$5lFevar)76c5+Qu{i$@mV_lNC2RJ(X$Zx-6O#KL%qnUV6>np? znz*#4no4uV^~Z=@%(h;)%@@q*SiYfJ4ip|IGm^M#&5k68PewA{A;Xt8www<2qnQJ5 zEDF>Cx*DkQ6iz~>$9%m|@DeAY@xQYTU{dvl(_(8_nGYna(Q%F$qK#WehEU|z$= z7*ozs`lWt}_t@4$uy77K@nHP%QCIkrq1q?SK7QV8T$TKoo)bRj^$;kU=Y*gC28h$G z{xW`&`+ghGJhIrZb-3*#SO<7bkep$Rl53B&eU9|3jW}1QerAllO0o+Lw1T{ac& zFnt6#-O`8L;S-&;IU0HaEA~uMK~zK3J(?r)D`s#H`jrk&9R`Q_iFJ)Ln6;sn8JPbF zxzT~)W1%6?lM+%oYqRHiu)pzLruE$2YYK2*&Y^H;j=buz|AD1e>5_?{@No~f6W2!{ zY@`j78$)KHi%AgirI+d6Zog#^SuNuuRIzmis7>c+0iw4;L~m`?ec{ywTp3t`nj{z! zW-Mxw<7y)r;w5w+;GFhuP#I2akqcXg)7y}<=X}WjW!N$u%C{iFa!@EpD3dIWlBw5_ z8~Vc>eqVIMQ#=E6=4Rj}prnZU^T{TFxV*B!291Um!xD@*|4ww@gw?S(OWGuc04-_U?*0XpX_A-|qXnffFill$%`i?luW!xHSw56B|T^l>@BR=dQq#h7}=5L=tv z3AvpLoaXF%pNo1SOz~*qhi2T1~|Nb82(9=2W!WR&*H(?ODs(#qD|z;+o|EqC5y$%@U-P z`6-~VvAN6I*P#sXOrMao!ON{v~uDz3x_luXM|jv`yqQp%7* zLFiY@6=`>1`8a%6U`6^$-W4fqZR_W_i*YcmHBo~c#WcKRZ&?`5+Q(ZM&Y6{jRXD@< zSq_yj-S@d4Qa0**I`~&S3*A ze9?x~ud%5O_xtp)4(`cZube0hvy)i)uz-;P4q6DC+d1--N+?C~O77LM=#oK#(G2Sv zrYdr~1na&R5?eIKR2$Nfk;;r9@U78c?}Zq0v^7avH+;LyOS=Ir0s-4MEt9%AQ}|m= z*+2nT2a;k33E05QU`7mJaS7nT$jL=tdYjpheQR&S+u5P08(C97kCz0!FgHG~TEd*? zssBF$o!;Um-TQ}2dO;`G4*V`H@sV>@&)hlrgGRdvc0^k_sF#IJ_V~UZM?A)fF&{W*5kpE z*LZ9%z=2zW@E6MCzU?iN44W@AYmvibhrmVumHG}U0zWi69V`@G^tc>0sRlH3iZkaB zN}0z59*gn3Iradau!Q~07wb1;lTh>_|NYJn19yk}2^S2wXFPJw3$OIS#tEq8a$lxoX8 zV`t7^^se&g>=ERY0%-ANv`G8y?=mZ(%?L2GBb}h)vDtz%C?-92(4;CpR^dDF;o^t* z=;kZ);JiINBBj%&SU`1cX8aeJ`tY6qU_^aT4je}q|G4}%|+F}oXc>=LQN zNF)vdtR3I_69<8ZlwKrHgUPR@IAVcZcKt?pY`S2^h=09mZm}RnTdf*d`aTZ=x$0)y z3=+E-Yzp&THpYZbnXTlw z^*Or^QQ`O*CgobEuGtb}{7ExX4CX^?oI$0Xos58XD+OIMsQD?9{fU$svzJVSf#|3W zkCEI7B8>eDSzOEy*d)uVUGUAf^~<%`kI6ozbc}LemFOQ%Lw80KRBlPyJ4jcs_ghxa zq^mUM9|ypO?y1RRPth2=fVfzWAPxq?8%+K}McKf;ZA{nE!&U=K2l4{y0!Dv55kv@G zC|3#H*!`CiO5?S6y5zglMbLd@s-CZ7YV7{zMU{Si5xc)Wsw>vj00H0bPa&Pd?qB<~ zwfleL8Ss!>eLjAYvsQ}w54*q0_Hf$+(1m@Vgow}+H7=JC<<3C4{G<_x8pNsf8uj$v z@ahAzYf7`5d%Yu_cItJ;98_?Mm>abP7>y#apP%x zExh_`vcSut-+v_%$w2&D;j6$D>hqO2P(i&Tpg3VBB}Jpw=d?l_;uP!~A#J8PE1CTv zITVulxh<5;h`F8l6rPfgKb=KJlO24qMF$5GXaKjVHQE|+g+hXvFxv6h3?)#d97~`X zj8*C*S@(fzEdj>rwTc3Pg(}s^$)^ed*UZK zbYUig{f?8k72cH6&^K5SFxP`BjEWI@6Std3!z&ZeQX$lvU{uL99duPvhNvk-`w^TD zOf0z3bIidRn4(thp|cE);0My!tII+{0j3iC%RJ#Pi?nXL=mGLk!iH8$DH~J$eN|4y z82$(&wHZt$W^_AUCD4De_!y9&Ey}tH0YE2WGK4Xf1}aYukjd`_L2>leB+tcPW?g_s zj%1NzqquH`aUMZBO+4L3B%8qVIl|-UG5}pO=J%|wsc{}it@IkQ9S<7k4UE=4zhPV| zm+{D~JTN9|GzV-C!3J-P=EF3{o8_|LU4y1F0OQmi93e8OHS22t)uHTPX3XG=FiWdh z|Ic_z#&(Bh<5qu#k;nJ$_U5*h6`Km0Xp29YDa-KH>El#jyY99XLSRf}ix+02Eq+%u zpvgN_;Zf8Mk;7MvctPsVF!9K`pkb3Aoo_!Sw4{70s$61@FI0Sx9zWY3K87&cXK zO(0es9ET3x8caU3Ypyi`))Z8dpmjE~GCz1Uyn3AApXS3nK7fEqZrCw z_5$IzXdVlM*2~z8rQ;grSI-2l{ce}xidK!UJU*T25lSk+!6j^Eo6gVHU!lT4V%HQ9 zkMPuA0o59VPd_)VfYenhIdQA6uve0K?vn`AZ;%R%gUL|kC;g1DNqW(&+SYL>tI@1M z%G7AqTiI|XWu{woD02(Qv}e*I5ulsm=kabkERkt`^uN-Y8kqg){|Z9xc~{EJ4vZR2 zjq=Cw{3!L3+R-Sf=0^>%vnKMRd~X*}k@2Gth}7wSLA7r6UqBJb7mCSa6GW4@JhwO+ zU(p6`pl82kF^wf)??{_da}i`RpK6_j3-xz#qy8?b=P&cuFn>SaoSNklCa3A;Oz+X$ z%h7GdpsAU|JeNRUrU=njP&G8KxI}y;&)r$<1|LSh;)5Cm0&74{+rd%br1bc(O&mJp zz7V^h)*>`qW0V?jQ=tSXu|)|`LR^ezOI{766h(2b->4_DaT;j1@> zZ@*9Do~UovhMq!X5(rVsMj2mn(9h6h)g$3G$obH&_r)Gsx<@;psTvQjV#xXEERz{~ zfl78`%@Rbh?051gs7LvD!=};ul3xNAFpBjE3{U>F$VkUMkn$O(%*WT!`39G)O^pB- zJQ+v|_!o6$HKR-}<}q$&3h2_tb~Kfhj2cqF(hE#=?5orDte1n!arhzs8I<%vlS|QPAlOs zT71V!`1e=|-z?ym<+Bnle29ZUE8&UqG?+XFk(r(np%Wjb2whlu={ssAd`y6N5_aKt ztc2pWe8)=I!+HGQ*h=`}2dxpKVHiB*R@dPtxzpKrmgwMrPb*;?I`NK`FwdHL3rJRM zf;e7FsdvPty!}?f%@0sA(@MA=Ps!UJ%o5B0%dLd>+;17|X`;fdevWv!?yO7(o4`u= zO;ll2jNife^^TRWkfHI@egH(iVHNji65dGb zE8+6Lf{Joj35P%t$@^a--=O;y~@Lt!rPdDH8X(;wdlL| za6+BVb+cCI1)0^12^qY~A9GSxt{}7JS%%_|BLzoVNqE@_04RP6Vgeh6)XjkiT@#l? z@1NLUG=A4SGF81o7vTwh?iKh!XjG(K)z^kjp1I)1A^i&83I#kP4rw9E`P(uP7cIw@ zL|t=s`Czge9h)169o}@D1_P+9yKbcJ_9uFgPT%4yUa-VV$=a$dO`kHzgFU+>($8?8 zWz$>k4jtCT-iB9A#oy77nml6bE*RZn8a6ezqV3xFv&nS`g&w`dR_B2dg;R1mRKBll z+!{W019d-a{T?2RhHp7Aim2}R#%R@8)03mqJa@`BsMBAviF7f6ad`-zqZ#`;WOqU( zab=^EYq&eXM1QCsrKSui;&1WtFs?EYbrIh#XWOusB}K>HZD`4jbR)eN{pw}<9yZ-8 zUQF|NY4Z2~540um{>dwGz*{`_K>&iYVX%P#F5NkJAyw!ZAdHbh!cLOs%ZW4G`ZMNK z{dsoy^S_-_l?=Pb!12iQYlQ0Ptid5RYY^|Q+gVLNq**va7~BM`jYC&~A(DY`1^qf3mVL}nfLKU-mhAzA!yp%r zJdnDC1gqpBr%V=%K5dGd*L%FHVhE_Z>CGsXfOyaj;}hi4AJCzkgqi+X0vrgQb)OGO zw1D*6EtEan8Z{KtJAHlxh}4DNg{S1{(jgNpPiI^Sh)4Pdqy&;rC^=JvnM1nz9->=^Z2~|Sap)A_LbEPjV-)}OuGk-{ ziNL&!IKFOFp3wlus2&_ZPz4SgJ5U>f$dj$)92PWQILu8UKfQ}VwI>i2krC9!P9m0b zd`h?#3tl3O!kpnUvKPVG6Q0tlhE0}1n<^c6P8l$%4MgoeCpIv|29EX`I5jdNt+Yfo zg+}jeM~=t{cD>w7$_#(26Y-CdhJjk3IZ4mk=>pe21%$aNrU?7fFqy$iL zgeGiIP+2%UI#ZAvK=}UHMb?g5Dun1(&%~?NNp_jIPA>hmzunxnM0ZPf_*+jP@=zM- z;gcvddv6>M1M<&iWxQrl);-FSu26WkunEP?~Nj( z60(1|(}OK517?@C0a8q-bwbmYoq;&?!~*h2fScm8DzbLzTs;h!F^%5UJdsi!RK&># zd&x3C9E5GnE6Sl=;r~d5Z2uZe9`S^rwqlM`J_y=}G?`O%uE#>*nC!dFT^}0?bc)^+ z4-gf4t~6N&{;UC_qi&?xwEACndNYHeRZFw;WpE@hXEzYEy!~bmM^EegW+f_5TfbMf zPQ1oRv9M2iUhWixA_?+NY6^fvR9&D?X+p{Fy|x61K?t{A2m--=DJVE^%W&NKIHqkJ zR3+38&}7z$|9TdrD(HGs_tRiOw&oIPAcNj(OMBSp@%gl_BH{ptHe7ZP{R>h{n=>4@tkTzzM;iR-C)Ht$lQt_R+$29JtgDHG#T- zX!O}PB zBlf_Z!w|YiCVaA!11ES5#%jTtHjkKy=-{+1Q}q44V6@e#XBgU(=+k5daW%ITFY1LpvOP*as;o#Oe8y{sN3 zewT`o@UfQ^0atF)8g`pR4cABw>_J)$w`mPUO|yvGvw-K^uy8}7XrA0d-JcDqc1o11 zNPj%CUKK6iBQ*;An1PY)_Z$LF6f$oThdP7KuDU0@mN4R!^s@m=6PS0p?7uKNzo&zx z&k;h6dYA&o9P8=2K5y|5Uq_lbRiZCQFGE@vr(0=$w1w<13YJ7znVsOA+?15vqHVlz zM-D=Hl~3-$uSvpS^0=Rg(Do0`Swj`tgD+d-++gZk%xsSq~s6y^=2KKxG|U1m%|4uKXE^ zZ7})QAZ=wdhjye1D9KQE%Mq+1b)se7dP2yBy!nv&B>uFcW9@_TLAfofbKe#wWHS1r zT4x21Jn%aU_CA&P-? z*pDadN)`~o*FrQvOHnyptjSm~GC8p?Wppb8sx>`0ibkSCs)S=)f@==J(8th#j8mT8 zfjyiK!X)fPO*m5@F30g-QzjnjT6YGSOov$+%}1? z54M00HgQ!OtXzRLjRm<>E(h{p$mkQ~#}I0QsvP7h)*>{+ht%B|9#CdFxqgd@C`B0x ziR_6pH8I)`a^!_2qZsHBA|X;SfrvKrm7hdGTvQio-42>Ev9E}O48cN@LaRb}pt0HY zC*mwWT1NO=!QX97B}!t+Gv6iB8nnd>E#skZjK@1q%uQ2CD;;c2QK857m3i+NVwEK& z7^#nuKyD;~czDa=rV?3pTC^&Kq>oOP0Ft$#%1~F&ZFGx{y-{i8<{O1Zq*2gF5~F&L z(g+7GSM?jcL5J-~;nYs}L?I>#`%!pAn2^T_XAV9ltJTk9faf?jD&H|@9tr%*bjd_( z@!KVO%*ixX^swrH=z(w|=Rr&%R_Q#!Yt$#(scB>Yh|59CcK9uA;Kp$^RoM^T{5$$x zw5&P`DbKD*$$hG`(C#)bp?Rhkj2?(5EN8HCFBtt0cIO4u(B(ftpPf4J$jo#32qody zKO(L-;nw#!5JnoalbtSFJ{cx9m`*~4IZB^7Z1i*);h?J_*@exW9ac7(**k(M4jX^m zj#4Snr`n5Dgn@Ya#|p_&ghT{S=Ij!{@0TYfoQZJ?*&u(K_YizjB}KnMn^f{VUKO>6 zSv&zf+R|?N3Q4y5KS7dEftoXiK25(nl5}fDkC`cTiJ;)jt_sYOA!b%RoZsbO16~7p4u9*1MQXZw z55R})vRi!RSL5n($X!ucsZD~_FT9=uz|&Zl^2t58NfHK=zxsY2=%xP|9f!D z4g{+JsbYDuum+Km*>XCE&ULYr_SiY+YTA_}fYIUtX_2&Xf@!-C+yT?Cwry*HQUjes zNG{(9q}oNUEBSi_1ogy2D!Io)Y9U_04RW3VXXew;ys9|UU0>7BN!cD#2^u{8j_YX* zNQ^b3XRY72RDYp74JLmFa%V4CJ+a$}jQPMTz&CF&Gto^_wTzwl4UFgZNzJYt#aZi4 zd#yWEpvN(c;fa&(?$=leWbJdirSXfWSB7IhBDspN0;&ch@Q4=_R5htdL+la`WxBY> zJdUz77g&-&>f~cCQA>Gq9$j{-y{e)LTy4x(vpHvhbGdMT3m{9K0i>D9Nn3+FtZE3r zO1&^p<3Ry3#Z@wv%cqWc)XRP0syELVbHs^;;-N7j9k6;I3&#j6U>Y*L@V>AZ(V>De zU&(whW%P1Pdbz*$lC^r`Cv~I{fBK}7x*u2H`eF%2>%22b)7L#>!zg-|jSRcr)a{sy zXi&0NK{XJ84=(zi(%cr0<^*bjl3FTV$+zOtdrm#Tlr*^N;>0F>sfw%#w-#f?p`J%e zfUrO3Qd$EmGs#IQMKG8-OG?RFEzxCp_;z{XT5TPkl6zpytA#-d@z@){z6U}c?4`Hv zWwPQ!h|fq6RtL--;k8~VPlL&;2W+zlrV>%c*2jab`>Ht5oD&V6?yeau(mYgT={0Gi z%EkcO57+9b76BqF!wNncSrd=FsL-TWo@YcvkkKCiKqm=DhWg6ZjQV=vdW#$x6Cto4 z<2=hW4j|W1geixo=~4+VS)uWUD4h#Lz|sW`Q7?kdo%Wq;6d4~xc-TKymp#C=bXBMA z0+6SoJ2gv~No-n>Sru_OR?-|ZwZq;(iFQUC8}6@&f@O7zgn4floYKONC|(a6dX7l! z^q?y$1qixYB0qZKcHAX$YH{qO{D5m^mSYye zEhMg;RCp>P4p1ZUDc23M9SI3}f(;`i_+3d3=~Gyg6p5E@2L%{oBo4DVZn>tC6x4#^_W<9u8m5gIk@*!}+*0yDP8aup85r zU*76>#UF%&(!0XYucFG0R0xBEu)Q`jyYfwGb}%^&UD2|l#$wKRXBZs11|`cGYM*cL#C9)ysF~X)yWP zl^l=$Abxbvi;{N*nk9rXK3|>ej(QuOYH-6RM7s!(?6&byuv1DSbtc9OFi@jkUwZHK79I6@QgS zV8Vb79L{_{Is?61;+1kXC%0v1N*jwq88Shm5;v&qM6{!rtd*z1=duXEtiDXHsW z(NCi<667i;W~=piCD@AJJ|$HJg@EBx;m3!~%z!vA6Z>&-eq?0Is|k=X_bQ8w&&m@v zUw|Z>oPKQ9W-h|Zo3|;j&fC6$Kq)bjgQqRcGEOIQEikoyT zbO!|FHCJ%729w)XX9~!y?(dNBI*5qyKsQq4G6ZgsVP(VZNYzu(W1`mnYk| zV3&|`-Q)5!m^?JA6Y0Y919t}6-!UoX4WOu4{&>pks=R#>oH2+!vy&14WVDrrRnQ_x zGUf9`lGUxB2PxMx@1$+A`i3BT^>W+Q=jCZIIScDXBhNl`45HJ3(i=$j`B~VEr?)V$ zXw4zdzU4J{k!kMtmkSF^6V~gWF3*06oK~J~#QCFEp4}wRD$lON^LFIfm(Z6?dG-{z zfbwjSRFxsmIHl*7XW`fnQP7AyMru7weLRsLLp0%FAvYNeow3>u$QR^kFnK3vPlOyh zZVV~)w7--f74AuEAj0Pi(Z^wHAKfD$Ge(cV>ZJ+l0@QDJ+PF)qZ4k+H@lU-TVc!04 z`JzjM>wau?Lxku?<5Rf)Nd}`y&AsO>&n?7Bbv@BI^wxL-wsh6C*CKwcHqIlfBi&|| z!>N1(8(r~J?#<}!T-roB8PaLoox^x<^EQ^4h)oIEIs~9tA_|mj6RC3kA5%981=R$!Nn|1k#K3*J@ZYHF@^&TYfA*bV~3_6V+ZB0aNDIDYo=vyYoSkGfV< z#kQvMZB1p{no1?A<%K%j+>QxlPgc~jX(8!wi`l1W;+hR5Uh>=)qB1^E2}Kv{@Cy0q zD3>3%3_nh99L+6`iVqJ9LJ@}K7FqpjXQYZ$olOYe1hyl`_e%;>!q!Fl-)ET-7FNT0J1uZe^ zd94>P4H>icFfm-HMyJZ)yUH1Cxfb4dZcAv1tbyvj<}hg_eEF*%p?=Y=+Jh`ejJVR6 z;u(OXWq^No4zFPppyZWcX&yJKc@eY4eO6FQB~ltP8fdmjkqsIlc#FU-2oPb7m=-Zh zth35zIOZb7o{s9vV9$IdL_z`L>L9o?x3m$Bvc|vRdT(eW&FTRBM5Ot`-Mz=9+#67| zXPo1+AkxgKt63YQWkpbjijj11YMGp z>X`XJ$Fc^)&#|1Y`>_lXOeAAaRhfWI?udCHy>yYsCK7H>;(8MiuFy$DW@)5Ui8N+x zU=l)(d~!n@0O=~G1azyHq1NP0$53{1KgcODrW4Rg3>@;CU)?-efi$O&!#${Xd}Bl% zc?vkU;lz0kIjSO^7tw?zd(eeX2P6F?fzcTR_w#7irc#DzA&{6NtR8s`ANyZKR#iF; z{qY%Xn#!45T1zznG)``%zIbkHCBn$V-{g~faEm0s1$v23h;Wk=S|5Z!PxcQs?Q}37 zgk?o`>!X|4G^v5q2}8m(ujyU1>0;CLLNpD{LT?gu=_hNSAZV$6~LNYQpk5I zmmHRH&~2wx6Eh9?5HPyMvfH7o>Ej-U!)_2=KT1A3!84JM~IlXBPs;#AliuCjuWe4QWv zbPQUA2slgtU-^FBnW05yQK(Vya9~Gw#fv_A*=0@}_WD#6S*IJCI2A5^KeBn`+QBBz&0GoWhP zq23LYnEk`Eo`_B$kmIBU8xx>)Z;I)Zu+@+A}O5l4T$q|F_-=TZMU~z z?-pz~hl#XaIRhX-(yhLWhD4!pz~T+-h){0}B#$z18rJz6 z9ntraLR=*>U80gz12{mQ&-+4J#!|_cl{6J)Pj<^d6xI#UjEvk)en6!80%~3&U|>UT zSQl^TF;NAgH7r6QMB^q3aE&dlPI^;3Mm*8a$n+>5FDaL_iUosYAgO=}B4& z^UQ$B@MIVh=hKQU!yW~s5($gX(+jc55OZi}yV*1ccM)hjm+VdRAHG5~MtZhGX)+f@ zn$a;z3kN>ao_K7P&{oc(!+wa5iV~SMdsN@dBI)ehC6LV zJCLVM3cmQ?in`mi-#US)hrXXlPKR`IPuzE57+fbPFC4Y$P;WL-jt37EpEB$Vkr@`dAz?ohv z3OT^ETR0g?OMk-}B zhQ`xEiYtKu4n_cc8IObRQ2`dI$I&ZZzva{6fluR@O1n{oq3P@Pod`rL^u1}r8%Chu zqnwCZIUbR9ijg!9Gf2wQ%NzxAb`;?hwXR%Um&KWE8XFf(M{a&EtT^{0hSux4G8l)P z+gv6XbNl)28T6wFL-sIEjE+nS%ZZD(ZP0JrXCe@{Kj_W>yg_Hv{-FQjJs9*y7}hJ? z0IW@V(9;?Haj_v935lV?z6mrWKAixcW%D8C7e7=5@-0$*mHbLM2NH zMEKQeKxAdZ=%`yhd5cEU z;|@0MbH~~l;EsM+_JYHWnRolMV1`6o$~v;goWo$zVFtV$#)J9z-!A;-%YxAEh{}M2 zi)U(h3u>SIeCzL=bvJ{Tb3m(fk&}gU&lw16j!uSnO8+PuuSc#iuBlJYSVsBLyx~im8IT&tdCs`X*tibHiVYqf>@B2q?Hp6hmakcCJt9x=e}B~<_!8CP zt2VA&U}?c5Nf1u#9FnXm`VzsKK2}^_pe1HPOBZ-8E#Z@U@YhU(_kM)~&Q$?uDs7Pz z=?t$rlG=KJ+@Z-0V6 zdx^#RLU|&Mo`|Ppe|yf}a(0)7K(jtF%zXAvskfZl8A{#cjglJ;Ssazb>w;#4 zaO{tu8bhS;McP4Ci)-4bcuUuC4A2G!M;fO5w-yMQ-x*_0Rfw_xW+iKHDue}M{*Z;n zx5w$$nS2Ep(Nxz)O9c%)0FxO#vPpe`wi6Zns@v2czaH5o7LC+y%wT$Hwr|NYmC=>G z+G#!RtCTn^NVgL;%}KNKujvzrFmN_-16>SNJPEB zj>@B&fS|CT$zTLnguG%nGtwJweUYOeRRH06EpA!>?F2Jf&C?iGWcLouJmA;O=UN(F zFHeKX_ai#Ns|EN?1DnXea7KU?*@{Nk^LEPn;8{ux0)o|}vY_!paU?Wmj2!BgQLE}4 z_iPMdhW+)ssx*K*6oRz>tw?L_g|rYtjlV ziF%ZwSP+{*Ig#NDN>E9>VLghf9dWqj-0MT5mxA`!v#VLXq5&dPt;;rToF=k16C+YK zrxKsl%=K(0D=UM+?}YRv|^BvZM>M+ZPOio|P(B+2f=u`vDYemJA1o%P=f) zru#)`wrl+rh>mnj9y4|3%FSaEBJHVbg+$qL`1s_!+2Qo=@C+j|I(wZq-6(VuM;IK+ z+NHQ2o+F21w0;z+9$lg8xZD-2x&t9$Q@JR}C?5ux>>N1^(+g3Z(SvVnBh{Pwb0`?L zm-5NV@rbb??7G+r?`>b=6BUe?@RU4>wc4UOm|QuE`M|VAN#^Cq(lIPVX|{uwNM~qt z7aX|`vPAXmqIWLc+pthR8?fZ#*%$N*qKHI!#7-H9vigB%z#oG`zCga2b>1FF-e1nL zsCh=729wbFpFcAo?>V36nt&h(w9d7`lC z2Smec!mqXLiq%5Xc`3^Hn~B!}dIp%pjlsoDfZ*b0mFTc2s^Z(O?l?ma;&IJyjK7Fz zOFM|C6^Y53>rqw?;z?IuKLvO_pN?5*L_vgOw{t%Z=BhxrZHJySh%{~^<4N@Uue{RoW+;4l7wdd?oZIT-51J3Lm&2=LNOv0E5UYeay<3FJUU$Puc0Bfb&9 z;MVM-6t8@5PaO>-zt`zvLcsX$X4F+v#<$^rdZ$6%jAzK|lHX~N*n9-<2XdS&Xvy2@ zhQhp^&Nc3TCqjOnhYGHJi&Vgq5Q!8X|DTg4Ah&`fVYByo*@uI;Vt7a{`j9x+)c#;F zSRcnp)~EOoy3^sWRpOzLH2=8d%1&L;-f%fs3siEqbW|?@4dSr8vi3^N^Hql zfgLp1yA^L}!%mv!T0Q&3Ub&D2X;Lj?@lJM9bns+W3~4)qXq|qxA%~b__-0ESq-_3 z-NwrThHUYLhtLaVy+n>F6WcT=u65Cu=>@4nITEaKXVYMR+Ccr7#LmxQ0Tm76g*{jx zhn7diY_0fh#;0O-oq&xn-T7Fr?hKhqc>5q|iP>A@IZO3e!}UsANYdD+63Hw8-VK+y|$QMmN{ z@IUCgfX2+f)_33)sQfl&5hPAqFEx}z#)VeIUZle(TRd3oyU0PR9>1_!ewq$u>N*qq zDF9w;13~%aO1!X7XP*@4)98@^qon8p^X=HcH|fYJrUvO^y~$M`$Tg1n<&qT-KZGF; zx3+)|%*(~I@W5RM;nv>+x8~*IceSi|c=^%=c;%tp;no-M*NhoPy`<=+W}(;(L4u8a z&(9>d=>{C=@`ej{KW!g{E&|e0?BStg+O8&b z#HNm<>I_b$7830ZCkV_GrPKa^t@#-+H=PD}NQ0@w8{$wXx=k`=f+Og);1snZ4=SY4 zRAdpHq63sRZf@0FuaWzSMy1r^6M6upYjZ;7x+h(Pk1&V-qYRUj-U$G93RZd6m$cpS$YHUh6`JjMg#aJnuEFU1oJJMxrf`Z*9wKTXzqPdqTH@BioN0JXa}2vfcz1v#e!WfR6>i%YL@MmC{&8zHDHzS$4kM2 z5sIcIkiab%{u;GctD^3*Ra2}qK(X)ld(O-}^XxvG1mxb|{k`wo&!^evdFIT_nKS2{ zIWu$S49%~;EB66(N&+<5@8rY2rbRvFIWhp&%h+0>Nzi55V3G!1SlHm=-An9J8!puz z4`=tcU$p1B#aB?79DNS$12!`#(J3iFi}6%%!USAq zp_GB5-lbF+-6*4h3%FdxCT6CMmX>yBFPdXz!y$=)%l?R=g9!*tbjo`tGv0ti$d)UO zcyZB9ZrBjK7a`Ii@hU<(miz-&&6KEUqzG=GFthTojt=H>F&%-d%A>}O9!)Z_mHEuG%=59A+c*(+I5z4GpY_vAqy}9gzxXZfmyPZFHr$f5+QkExePQvWNy;I87a1 zwT{aokgq%!jYMHQlxEP?mQ{CGw1R|?HhxCK)V$4oL%JL82^`wk1Nm`<8h#H90?_bX zGqAXnslwV>pi7HY{30B1ETJlU#k6J}u6n0tRX5^QZT?{x+vx|XXp1c4(#H1wa7g+W zjqQcpgu@W+@cjQZq_g_=edS%zkkumoB@|w?wzI}2n=Dk~40CC1?7rvcWTwJ%Q|_xRe+i}$CkE7Y zuTsSULHw`gj;lc6w6B>JRbjJrK4wOG_hv^EB0S~4gM;h{db$WLYh`Op6FW@{>pLQw zm_{qrogbmFLwYeK4pbmGt`M;Vj~X)tLafeG{a#ERp0|H$ms6&rI@Gu==`2pJ3B}Szg|=Gqh}+VG ztOR$;O?&C%CrqJ4# zTTaFL=K!G=M9s#;DA*daG=8b5Laxa;OO|w31n)PDS ztOuKBod`eIf$(!{k+0J%$#Gj}z%9we>NeJ;HrDNU4i0O*Y24IR-i$&yb^-N1TbQdAX6pR}O-=oY2WOHJ+x4@_5xcL4{@zU+5H@$} z(`0UBsje&EhG=NL>0|3Icn$XR6P({shJqVSs_C4DW>AEV{TL0laYyq92HQ$-DpGo- zu__^JsgEEb>R8jKDdNLa1l5DA0EbD02LmaG=~;%X%~tf{TmW zfCVwMsG&2xcPhTMreUjHIK#~h@vSIdW*AlE3>KwkKDR8Uu-V*|MbqcQ6`!!`QYIsc zG}UI%@3eBOdZ?HkH1`cr7IKWKz)_K{<+-I~YJBPx?;_x47a9;46+I$NE>wej92fw| z3>e>z>IsMP?LjDCq_#<+AS;(99Yw2=0)a?1Y^{ldqV~>r+^Y<~qOIarq$_yVfadM) zYk9LdgaCKAXKU)SHe2FLCW{*mvvQCD!(oGTf*T8M(cUnaZV+G{8QB4H!#i$RS0t{$ zU@HD4(gO%{l`YRVW1K`soKUhO`p~$+I-(C9vFkY35f$Hz?ufz;5TO9Eu|?1dbvF-z z2Q}zmDG{(XN7g>{E7h%ANgQq^mh!;Cd2|Wo+eiyo2xBNd3Z8FN`$=)UovUW%*jj|<^rHjcHmY>bXSX{sR&@bL4=NS67BatlU>=5LX?Pt4L zpNelr1ae1;EE<_D5`#?T{0n7UsbV+QIlwXoitnQDqYgyWM%0bH7BM^8Itwrp)+~q$vF+B zj%b%sZK`2iO?+Lz^W6Dm1b3Wz64ik-P?DkPm2y!a&!Ro#1Q3)5>g)!CWYCjPqF$ad zW#E&lYigY_72ap7i12A`pxc|Q^g;sc{^RJ6 zeNL2cJw_J@!Ph6DQu*- zIFIuab_<$Eh#{b|fZ%v+G36jFPeE|JSQ7V1n4YkP0r$p)LT0PT@)PNW_ZjI6a z$~vM!r!Y+nSz8E3U+ZDbSZZXM!QkC=f%V9`4j*#U@Fzr-BIe^LFP+ru=qK6dAtz7} z>8e(`>RS3-Bp9KzYp2CalWc`tQ7z&M+{0$e6iy{vXQ5rCN*D`MRCu;7BR84VWwbz@ zM-UavAE>7>n`rq6W)rjLor%LBjd*ky5iiC|b`}El>pX(QmloFH!QoJZ-_&8@SK;Bu z@;v+yRe0Bf)QQmUe>sNdG9Da{w=;m=Z}6%Iq_TL*u7R^d0d7Px_lj)k$WBqAngr+C zONdW%Z4mz8*=Obk&Gj%Eo~h(|=+p5ms-qtY`rKG{IL3c~W)PY%XZ|*D40SW+H~G!!?(g`@poH z(;wC~$3po_d=f@w-Re29`yR)E);$8j!$4$?@QK@{S|)9@>{JRxLIr6GME*`_4~D0P zRZgS;D5ncx9f}c-`|LgrFa*QvD2v^|K_qA(s~82WnC0ZQ&jF%Fl7 z!nwSa&4A&o;kpY7^(*!YJzG|hXy&-C9t_utLR?+3@E7B>HxN3J8dx?raQ`CAl<*%j zd}n22REUD^P!i%12C_XCvTaGT5e1r7i2C4i7}Ek(wGQHpexX_5$(@ef^3|%zSn_dp zrLAXfd4G7_!|c;@R5Fb%k_CHa&k`eA7BVs#m68Q4s{HQA@-oDqm!Sc#&&lhVII)L? zC9YAvh!5Fsd{L!9v2p4vcQ6`iv~zcSy>NMay;VZ7q=aRV0Ry(y-AgBv$5ufNEbB^J&3W_!=f%wS8B3}Z;s_HnMAe~zy*a(9aE4LQN*j@4lPdX z>ac=jZx<;@C~bhkTxkLca&MCJ%XB#8EmTl(&~b9yTc&fw$xP=!D54g;5kvC^9oMqv z08x*#s4TC&6om+MH68>|E}$?4!-2297YS1O2v=Wu4?>eu>NJC1Q%C|}rl;2w;^v2D zAc{I_;?1!errIjyx{D)iPS&Z}80x&Kb2podH(nrHnPk)22`h*yeg;*9DIP$*t{k*a z=9%h&X5QqS-IBwVaHJ`oCYU)7pC{Vq+;K-ac5}dYrwB~#8^n4iMwY5_~|&)}COr{~$i8 zlU(H7qJ^C-3#ZCtnQ?OuXOGC*>6jC+qgNNZwiBz%*a75W&7T>K*Lv)h`E7d5@AbOb%G45;sUxL}v6#^fxys z_C?o`)cG4*ov>R8<;6HMWjZ9jnFisC@ghOy-an%#crVW&jFmVWUAhQDG3JM7Q5A?s z&lc4YB{*fFgu^5&q(=OMs`X~kN# z?P;?QjBZTz)h!!-l$f+Ug`9iZX+O(nXg;dI+Vn9g3Avw^zjQ4&)6Q7(Zz#kP7b=yz ze0ICSMEIADKX2Kh3?PM*2-_-C?XaLFhzV6Wu#}&SRA@GhUx6f8Qk;hxwPf&*UP7Q7 zn1i7*6huVzTY!wI{tI69v|fw`5xX_Ci6V+cKi7h#s*Q<$bi7SZa!J&E&eA1;eA1@9 zkcw~0pPydECTQEh*`oIYSe&!Mi@3;RMo|wgunX!O43-=cK%!K>5K~ss?yArSu{>E* z?hT$gG4;haEjeHJy*HKWPbH$^fY7v2dpv@OWPU@$LqDOjwN`&`fK7^PQ@%#G3)8Wj zwK3p<`bX$TU8(A0f#RY-JkXRVWObFwASznMZFqb0-%<_H`EN#<2YX zw4FsQ;WnYf@~=xjs9hk1V=$SA+NnL)`9_(R1WD#{4(K%)Xfu&%nPsM%OcMcLdYC9gxG7ZaWU&mKrAWox} z;w5|1xk^(@Fr>*l0n$B%NY8xjKn>6GSM&QP{(=u2#xLT7&ia0f zr|hi@EV_<*e8{Cx@~}n+N)@hz$=I$p;NBhh4xxxe)Zw zWpt`0y|(l$BnEO8C1mPTP>;hkR$;S1@ZJjtDDO=>Pz3%vED9SfeOP07OqVN+BRZp7Hb{s$IZ7BHWITChaHHBRxs3`@^mASvww@*3wgXr5Wmbn^vW9|D~Q0Aqb* zSW0NPP8!}s3_nJE7t(+~GoGVKKs9i&FkLTUj8w}5(Zr#B=56^7~{ z8-U!>*I(UGIg3!)M9-+~FT<$uhh5Zt9tjN7fKaNDJNZT4RZA81YH_XfDr5n}&Jckn zt2JnD@(d*%^s0GGlgq~TE~%q+Q07rmYYwJIC=%G*lodr8o4*{{#Px5xiJTeg2$D%M zxAT{NxiW_qlZS3K7YI_Quu~` zIe`#U?et($$7Md+rG{tW+9Z`gh%VWebfhv|AWz-djr-_)A@?bx5{fx?Ey;oPj=7mS z$Tp|3K};n&N1K5qjnE&{SA2Bx!v0F~}rChY--}nDL~VFv4Xq%Lplntq8hI zfXcyKrn(*)Za(%@sE^OeaJ?Mw^*F$L^oA=Dq)%2V0X~J7iLNKZtLt4zMOZTyn6tsM z{)_j%BH#mk!E}(Yv`y6V|?Vq@C?pM$HR!Mx*TMPtluRn16BzWIWn>ga@fEdSB)lP15aGEFs7)B zif7FXlAXOoO(zS~(lNZvY6{Q$L8RFqxeaj5FVryQKoGVEd6k@WBVq>wDe|BhJMZPA z$KGM?hYbydoXHRh#9(9Ul((Fk>m8^1ZR&ejJ1g>u?i-r2R2|sD?NYO$RYbLecaPb+ z5@||X)15^EKPgj8_nF54I~*3Cd4&1>0DlWZ>>Z4c+5dtSq1(934t$KYK9v+~YTOKO z@dg}R&?bTwqHOktLkbw5huwOb8hdoHMRu$v5>~XG+FR4nfxI!z=|317@**pXj!V$P zvh%stOg!UjgQcsrx^(r}SY5hW%NgHV6e7ZLq;Mkt8r*8rNBA8PGJSef$x0J&n^sRM zxkfrevImoR#V>kLF95X`T!bo&7|~gq8PVS$+k~j%ih`KThv$Tqp$J=0_EP}hHKYwi zQ&vEo>dMadl2r4tFE=Jb`%MEp+7Zb0Kv4?|1}c{=dWdqvKkIgK(XqG6#lC1DaInio z>OLMq`8Hw}CV`=D1T|?;70|v^H;M21aukj!%Lp=tyEbos;ARj_y+PyTDEM@lat&u= zvyXD1`UHlPTR8fLOczDO4CrzG%+hxN!wM!!m*cI_#kr=V;6e2lE2JX=J`I=P%We`67x#kE`%xod_nXo=Q}5n-^f)!FJpE$A;U zPUM^A=59e}LYuQ3`N)UdeEBH!3RDd-*9Z`h1K~ORn(GBc!`Pi!dzM7r!&Ea}0CIMQ zkrMtJiceP4T9G1Ldn0{!VlYyGD5%;-BtYx_UsiVqlhto96z8aRwD zyV!OT{E}posHVZ~5hd!BwbVPGYZ-9R2<geEpVs_)Tl3Ye@U6;^Y8@n`>2+Iq^*MH_`*c5rKVlVI zk6ZoFG*BIE$RsAA(fZv@RFddxOe8D6{84NORbVf6XF9$!zqA#fuBsw6lUbD9o$SZo zM@I_iV*Nga4eOS;%OE%QB)0&hjIr@6k3nI$$`|i-8Trgn;P&Zn`LBE9Rrbk$N(>lr ztt@-lv2X1%f#_0=S)A_Jg3}#1SHtaS#6*3l8b4cN50y>VMQv;>^{3#;mpb63#+pBiYMT}fOvs&vhwB=*=TN`afS0@Mi-vt|egf~;HSS!_&z!&X;w8lw zc3Wra*@HLW1H+cP)LUHY!M!7ydb^)0mNfJc}hg0m7N%ng5I7e;; z$tbCGrBC*OkMY`vgGLu@th==Hp1bcpqHaTWLS1S@s&~V{L8+fl>P`*dP*l2pYl==G z_%BO%@vTjbTg#TfQ+%t5xLVV&UDXfnM>@t2QwjsZxSgIfQf95<**0KZGY6Uwu{FP; zRnUOGu3W~8(s_CV$5QyTCHD(piQ`gK@bN6P0~WXY(xX!G?Wt!{8z;S#dNuXZ!@&G* ztOvbRx8aou8(!HBhUSWlWDDY@28e7Jp@``0`>gr_;EU3sDOKA$$ZNO#n z^Q$OUt)&G?(BfdQ^2Lzyw?fiUBqRe)Na`-=t-JKO8xNiHP3qP1jj3lhyuRBllb%gI zm1^iu*Y~HM+VK0`Cp{I2(5cZPbc7L!#jx)KJ{IjkmDCvs$dgV$_K2-KbSMD;Uwko5rPPLJUl&_x(uPzI?UVX!s%OKN-O78^P|7wn zX3Lg*8HbP~45j1!7DEc;ctAjdwRT8}GMRqdsx)aDsPIgtK4gja|0rcIj)Os1DaZUO`bL#dSU#5`kr3M?wuk|;~c%MnObM2IzQ&*- z2AOX|p9;&sSslb43lm;|0f%}4Ybb8z$Sc*C!)&H~{r!;brA%Uc;m-`h&~m8_>kL=X zdQ3gISbkP<7Y|`*&%@7LJ-C6R(ewCG{J(*thLUZUnM+-=v(9&g2hc?0FW-jeHV0%6 zMgMKij$a^Qya8H`=g_QbPU@w(ss6ehI2K`c8^t5~C+r9zJhsMvwv%{wXMc#Wa2hR; zxQ9S)Ga%Os2=-xaDqHe?%pKV}1Sx>~tDY(0^NKuo7wHyYQ!La9Udy&*FE4d{z6x(7 z4q?}K$6J6Gth$>JVnR<5zky z6YAvUXReSU3fyW6Y4Hmw4Zg^L&-cMiolq`ixqI*jZBx>K&4~=G^s*e|3^g7GQrsT?S`1WR5SVY+A4mkzEa*$SoQfYL1;ln68ES zM0=@oBupT*g6t2GbW@SAN2j{LGc<;4uFZ|sO<_j-AAK_FmN4qKvSgX^^Yc{uIsSw$ z^u&_AT)>E^_4*m0jGYd}k{`mGt-yX=dbNE@d9i^prP~E14Xl!D!rpajt`UFrlEoi^YpD-n%?F4rFbI)m$hNm2 zx0|Kw(gypKIC+p(#gdPb3x`X@#|;g3BTF1Spq#RFFTTCkye)y}QR)6__-`O0CK{+x zM0js=#TosvasGeB}Y&9M}f*bf7d0z(h_tq)S2xOkVhq` z!L=looTbu=!Cc!cghZRWMAj0HkckC~e_@-Her!40#Fhv2J>Jom=|W$&S*(M#Y@k%i zCSk$|2+CKvW!$C5+o!}a=nJFW%6)Q8b(DWbNU7u>Q?V_7p_jwBvoIKz)G($*5t>_B z04F@y4DFRrHC#N=UfCwSavv-)?TcnS4O3)S%F5CIxX50HGniEFDzfL9xBm-7mP{6i ztn|$PdqsAMjF_rK|A$02pf5#M>HGf`kqvKjUf0F>M&Z%i1`YalRf)T)F!!Kk3)_M} zX423Ot0#K;(H&odI%pNG4jJH?etg7?;VXX-1AKN0<81-R7Y)c+2ISykkU9f0O+ji8 z&ceim-MWSfJ---5w#p2UpJ+4Z&%vh__leeW{v>0(64V~Y)uyS5yN1SU{!nCuS&Y3E zmL+EK7<`%{pJ3vyc@Ln{@ioT8UE`U!_xuee?t?GG#QhqIvN&1$R?$)OH1+IAXx#X6 z3=M%*DaNVH+UyviLEkvUl;QvAW|SXc#xAm-12eW#>ks$D?to)YZ2KKO3zyIt5fs8y zN-<^d5rl*zb@ZDgcHoPUgR=w~KJ)v*qg35ikbvp6nUtrny59w8p%kGzrEdV;q0mSO zLw5q&HSW&88a2-QPDkHj-eS!OQ5?p@AeJPP*=&|fOK01s#789>#b(xA)3DiYlf{yH zK6SI3=G%h@j03p2JpX)&Z071FA~^zK(Sq#wP|@SQaQFvO6KU3Hfj^NGnlBV#dXmF* zR*5RF6ZU!`s0ukcrC<~W5|+nb5R?)A3UN0ITbigdRgOr1#=O}#-k&DL_4 zE4_KvO}7cfvc#&rvtq%e*jv-q*SmgBoNl^gF_%ox9o1FvW#~mQ;&C(;{+sN>@+Y9w zxKco}^ox<@@|k@A>B@c~^mk#zQ3T54o0@=f?qpGl5S_>td{rhkBH1I-XnBbiIQEEc z$2q3=-a$L0j~An9vLUAJQ2JZW`Bp)L=%g+9aI*~!m413*(0=+Zdd~1A=M*J+6bZ4$oi zE7>ye*`Qp-mh}wZuCD55*hWRac z4uZV8u)4T_3`Bzdt?x;X#GW>k{0o%f{Aci~(|wWw_>=h5&QBaiUy${usrXdwK4F4i zmOuEX%&!I3Y>U-z!{Y?T?B#0G3s@*BOV_`Ud{S1EUhsz66SEjzmwa<#cDMGQE zFqLHyf{VO8Ig+#B4)BSagT-#;gjbxSoJNcPeB?IHt9il<@PZ}BFjc>A4RVpDdE}CgVKxcHT46iGMZ|am1sLMII0bRknfag zC6uZJfI$d@c2-!4wOxyS7M^@43S*_FfMsBuNqeL(ea6SpId&YfI(=+9jNnSucK zh$>HjdAaSY_ac7yk5qEJu9bjuJT;yLNaY8R%%m-vUG26GvD-3>%ki;;!|qPX?2y-; zQ&mJ=cfOvT>Tc)8+8L2!i2Y(;ljYH%^n$qrtEjdieJCJ~eMemJe&tj?qb&<~v1$m10N!*8$3UoW6_hO z$Ozv@fK;sLabKum0EVyDqvla?YdlN5Dq<_Q0WaNoRR2NrW0u>V&Z7pNViDV(4{CGX zR^_PG!uxIm4qx{%gmNfXu-WP5a*i=xLqoZO4NotZ`B=KHVAIpfWj=;-K?MXGptph5 zbH9iD3yrJs7aV};QYt=>PC#Gb)swtIoypFOa3(te{X-&Rp&#P_;*yC|nIMR@efvq# zYrtnL=lhJG?+ow$7x|C@!9L;Sl?SN_ugb^GeW63_roY+cAFF)s93szXXlRIXhMsAwO^q*?Em@XscsYWx&vNWbiU~uDh?~#isNt;0PNw%OAb8x*$|Q}D56cmX z`c|?&8rU?jTWsY_V2+J`+40{3-UMmINz!M1-%0Y>SLh?To8;Q*YJYdI1JaKDi<)dw zjC)GpbXnYRzYMSKQhFdeVU&%BrYSvuiYh&v8c=q3=K$~r^8aS=f05T1ILU17qXW!Z z1DcA@c59#F0S1eL!e48r^%By&^0Jb%yrdJI$J4sEF^IB5sr-+EB&vQ2MPV z{mYVmTX&pGl8~b{*h-(B>Mla*iw6D#zyqZA-~p^zVdr}_jgK5Rq3;r@j`Q8fHF zlj{^812RI0k~0j{B)@DJ+p8;3Z2oc-tlg$t|Ep!{^;vw?{WSAc);jHef8Y=R-qFR- z)tq~k+V2M&0tz#<)w&qE8ePNv{?*Mfer_lwjjZZ3`woWw!+1=BBz^3k+?lf4?>NJscaSD8!mim-W|}`NR*p@ z-=s@k&FJ2y#@mqNc4e|s$i|XKqi~CG?3Q*8ZVNR-vLe)06Da@_sz3g@{)5i;nsDi~0 zw(*F9u)QfB4Y&@Zv8`;$QH7-jh}%-DIX8CLhl>xOiKBXjqkP0S{x)Y=5*+YLVr!M; zrdaYDIPd2=DAmx_)Yyd+MfQphhBNhD3~=2+1FC(FR{*6Oq<3%|LGhI46zQFYYTy-e zx`@gjw9oTpC~@%?aW^166aQ{yJDi+79YV#PJ+Vi6w0veJ-%vH_@47Cr8>Y{Mql;J!zK ziEDnA5+o=m;3}5G9t_A^%nZC`MpsZf>{Pcyd=Y5E3ft{gSb#xP$nN^MX%U<==#Z(> z^7v5Fa;Z3Vm2{GcC2?vcBrwIC!OMc6ii)Wj%_N1?T#EGxt^b%*V^qz>jl9c9NXm~#xzC9dMPI^Melr3&d z`K`~-Md2%65sxVwq1F=eNLf?{HzA5YB7K_^*RZyPDQWC_OleIA>}&)+HFTN7ZYZt; zaDgyz<$-K%FqFD%vsCm%rkeJG-hz%pRokWz}c2X!+_mVmy3sA+Sl)zdk zC~-X`3ySLvVTeTtSNox%Wb8d+g{TmRM1=|=P#B^fWEc{nK_P_uxTKIKPWA=C<6|ob zgSY{bsJ>dphD}3H<|N9b*g$)y>bpW7Y+NZ3CHw zOCoN(QfD<>D(^f;N5jI0_L7042g;zVCgJ&&3PruK7581}P~q`HlmID3tw}=NI2bP( zlgsMbC|f&Z0Z^an2xIkW74)rWU~zCQPOqT84O;*nkZ%FJVQofu!74?;gyanPa#{s= zly7d3BvQ3UlCXH-t#W^C1u_P8$5P&WV%t3Vc`+gQ06NH zI9I3zYPIF=vY^zJnFkp&JcD~OYkW`R|D7CBOq(iW6GFz!9lXjhba|E$`0d+-9!EqB ziO}IC$CzS%sM-|bhqwOIye_$Duz>^vrW-0E2h506!wca7Q|w#vLUb4lUSFtNyt5a$ zYZr`f*Ckk2YR9@#8$v!{-Kf457kakfLeJ$G&z76DBq;89hqxUTo+#;#uZ51`;MyLt zP91e$beK8RxC?D-`3`Y{i4cEmS3*-niB@;c~V>akb*e(v$b5#$z!XVUQ@cVvQ}1M zrWX5}k>I+vvQ`#f#vs>t=1O28Wi1`eu%>4gQr3D4DGO0|_S~OhA>|)pV{28h=0EFO z7}0|aqN9OmD!$HEv222(Si)^8LZJS0XAa%AxD_BkM$@K?terL)BUls1fX!o zuQNa^4A8&HnC9F{a6{s#y=tWVr~F7$#)F0K|e4KD-+b1zJO^+fUAq@u|6 z8(}Z{toV>hEmqP8ha)UGTbC-*%-H>(F`g{4!Yw50QRgJFfvMQUrHV5FAy^M}Sf|Tm z>|UW4-EqKV<#Ba*xkU+gVqpua3M-&XlT0JCS?Fe*jm3fY2kT_b(6p-AxB zD@rYp$5#+=c=H&rm~v-9{!L%F#zj+ZOTc{|q{n@O(9iOp%UIOTX!?o!6@ycYADr+A zB?TM_=Qv!pQuH~cXjnI{eoPhU;)hg$jtuKYcqf!%(teCH zuK&;qWl|xaC?Cx7Lo8K*F-;n5PO0e**?fVqGUJ;iM5Yl0hUW?u5uz$-ZWz+5UDugV zu)0cg3RUmM1fK;dClOH%I-qp53WcA7bemqI>mI)yI*q@7WwcU72jEx|ezeL6kxKs+=rTiMr;{t7bwQ0H zI#4|eFZk-YfEU!U2Y#rjgeWen_<^Eh2;Xy7)YM?En;t{Zw;J)H+5hx847acaFbcikL4&w1FziLlcAZO?r)_5504IjDa5s__w=ryd6hJ z*_@}>7UY%bL#dtPyG*W|HJ5B>7jG8wSSriD+(1R|94|0XCl_MCsYc12 z;HVHK%MH}u?()-_#bKud==A1T?Lf*dv--9>iqbd)oiI<=c*pP2t@@4AkQ^#OBN5d zSaq5yVAMNb@#TDFB8DAz@Y~k6chP1kqdEE&MQvNTKJ$*5ydU|7v#rVN;kmXJtXqZ` z`ATk@!B5mRgJsCHQMW#LFxqbReuD#0!M0nly$2#-o>-V3V8HaTMHmM8xz=69ZM&i} z3=D1;39yv&xeGW}$hy#tFf_4|fb~xkII*KjQ75)hh-(#=jc;{!qbm1Q!L4T@59m+r6CPYs8 zhucqbjj-?!181rRV$4;yrW~b#mU*rb5gP!p;6j%KE{mzYTdy=N+CSfaosO)d?$nWWs~cGpGT(OlYr2Ex@0a{g zmQ(```Cb$ijI5RB?SEcFVr+?Y7BTlv3qzI~`zj*cko34r$(>-MvOG@rcHnf}udXm| z6IyYxTgBKRw)v{K%@-Q-ygK|LPj>k{m8JJj!%ZyK%=LU7c!TDLx4${CR#%?%08f4x z0d^u`y&SyQJMZcaxTw`zp;n#f7ddTwEabFNJ^J?heU7`)ye;{nwSuEOGvN0qX732k z@gQ=;DZ+n)$`{$8I^>iG+!DTz*=kRCQ?aYY--O;CL335Obc>>Nze_AvtXypzBJJ$r zkzni)`-oKKVV3ji@L5jv_X4r9I7)gfcN3dWR~R4>eQwK=2SMsp&zHI>8UbWubq`h?yiJ`>VQs7t(r zR7uynYXoA+oOD14V>0#-UP5;dnM>?~!Q^aE&!CEaZ@V|bZwQU7FXb6T>%P!42nPKg zWIv>E4Heo8@gIKZD~Bu1+pv{G1nGzD7>60o!H9B@NymM@PP10KuOk+L`)FHP4Nd(J zXy~xEPz~LFZ%ANDj!g7XlKdrI1xlnFF7v0X^ik>x`zZCujTQF1uAV~5J1 zNSq!~b&-<~j5e_M2hV5N?H&6iamK(Jf*Au$EEBGamS7cU1Yo)7X-CnNK>U)xbi7#u zOc&Tdv3q=`D>rY$wt?PhUxD%bu3}g@=;52ec%|1!3%wxV{NN6%;Vd#bg)2mT+;ey5 zFXeQRcZ_xfLVxDYfxR6>AVmi3izg)I1hK^9=5$*!qeW8Xm+@5Ub9a$gdc1Z(>%uv3 zt{v9IaSq(BC%lFaHoCiPUbBFTr&vO(DS@Y12d+E^a86kZ=M*@p)VIMoWi^~rsPo#5b4nkc`vT{bXX|2fdU!daoMEbFPhQJ_ zJ#F0B&DsZ6x|&~b_Eit??tu8B6(Se6w5-OiMco2!41-b zz&&*vHw;v6*ivbClbajC7uYW7j=zkDGDPBkrF_FHm9taN0eI!Pl9(mI8V71|Qnwa_ zOEvC{!(-&o)El)a31D2C+PLFavs2GYYiIBH`|O(6V>iT*HGe=YqJR(Z_+vcvn4i1? zQIWt%Tg9hgDKKnkO^_12OpVWf{i4>p8>dXZ&rrs{o#-~G&tC-9UOGlp}8;u7jyHE~SO z0n`-VQl6Wy!(Kymdhhavt+nMiQoIrSmC5IpROYIg))aqvLT##dwp_!2kGHGJV(-wK zq?re2xTAu@%EKf1bB3m`3dySnC;7G^NG?|a00(yN{{&4GO1(~(cXw}bZv@2mJ0L=@FSTfnY?C4`S z;!M2LbGJHr4R#;;S7Z0#F{ddY#5RV%U?Fejy#8%~(jX?8nXi8jd9OVXnzAl-Z70rY z(klg+p-)=Vd&{kph=0}{?*ogK)z&QPvtBl_KGOf? z9$*b4cSgK#$tiNvr}#G(NL*b&_{&5Z%fSjQ7Pda<_d%lLJQ< z4o4%=OB`r99Q9mrt&(|i9Q_F+yO>@!v(9EVgGzQaU~M6|9)&Jw6)2OzIF-RXB{O>5 z9VBvhcK@G(NoeW?wQsZzRDSHSl>qT-!Q`MGTg#gfiUnR0ReK<}(7eZk;q+YyxWS}W z`Kg5^=u$LGkxBgK^4v9HmQPr5!b$a1wZxV!U`rwW^7bp?o_ie=l!f-j!H>D*n$&y^f3dGHvV!UN4=Nr|#_ge+*V? z>YC653CrCExu?>q%Ura@gg!L-Yq)_A5-GQcYLJ_9Hjf52#$Tb|sxtAlN- zn*DaSp=PpKf*K9_?%0*r0AaCrU_yagsgxGM{U-%5N;3{5s zgb!hfVGJE0|h4@$kKCH??}ko1Ln(;k6>{ip!K zi7EC_ZRP!1cd25R>?7_@Sha3?WkO5C-LZ!n?ru4~@_zC6Y`?CtCx_y7NWcs1YkkoX zp?N%rcU|MA<@{`}quZ3?i?~{)*9i+jP61D&|Lgo1$Jo`C+@ol_AY22YDlRNtS^oLFQSA+D< zk&pQhw;G7^Ntt1xgs61Z6MHl$l(v?{Da@xO4*Ac^sHg$;-iYaS1I zhn{%&_)o@?Wh#puRtL13Z1aL_lqi>ey-A-Eq^m?Zh=m4XuaXca8HlYLgaZUMkxEy_ z5eDL^k`SW|M0-hySH7hL_?iy^xs5en1P64>5cBaYw5X3I>+$Tj^)^#NZBRmp7T22e zLxc1JS}ZUSyOo6an1R^RS&9}18i=2kg!m`cW7yTVm4x_>fmrH82rcGgN5|5l9?xjM zW1+iEu39hGA#rf|;4E~J$u>I379!gxP5NJcR;tN|8;Jib39+YvxT_?@pRq$F{9h8H z+dy1Y65>t+ae@yaWcvVyE=#t3@N8LV6rOz+nr})d4@wBpVunfo-A_x=Vm|}%vyu>R z-l#48PDzMg8;Gxzgm}b2%r6OXtAY5a4-U+o zKRzmLPd)=xBm>kTuv)OR+B7h08C4-Zm*wuqUt7udsk4efR(c>`C5Xq$fB2@-=xV7e zafOe^4JPdzgU5-;D|j4Mr*WJLP&v%2hn|MfP*kiI;q7RFk4?R)F~6QIPlN{7eN5WV zB`uchK;H1M{R4bK$+Pg2gLM!p`K@ngJHMeNPxagR2a}f2w9iSY@Zyz{@}IU3C;6B@ zVDijXY=Ti_$svBx83XoyEgDAwrPnZ1HfqsW zo@{dN8JY7=FXycVImeouPd}`3@fD<74$!(T^>Ux1xt-Gf^$kjw8zeU(UwKshzDfJC zra1%l1(<6%U8|+a^PXC&Yt7e9&Kkuj;DcE6W*I>gvEG6aw$ih-XVe#0!ysv@Tp=bNmD23bi2mwvoS zuL#nW2oB-^1M&NH1w?QV|4eBEI(-PD=ahHvaw_i|ME3Q$N#)&@@u(@|8Yv?f#1y*0 z%Q>eY=hsZmPiXDQNl3Rtk>-A%m-{`M+YLqYOzsM;_oF^-jx}l79|bL!xq7U*OGLMK z0-M!QAi9+%+x?+zMFUD-i&E`+1xsG;6?suXk?RcXf>4oIHHbA=SqZ>I`6$iiBw(4z zc6g92Bmw7}^gV<00tuLHApZD3K!Wfz_+SI^SV@R-195vvh~Ir(NwKUX#0CR#jt?Q) z;5g9++R;bh86D_4H)C=g?&UH{)F}>-tx$2)nQZ;{yGDn|c7#dq4blt9Hp)Q!M@fiR zzNSrHQ4-=Q1F^6q#N7s>t|Y|u2I4Ru!YB?QnVd0|trslY$nMC#_~pVaIt{cOcQ#AN zOq(x1Gha($6ZrJcV_!)2Yw{NZ;y8u)s6tG|PxhDqqPBIeZi3@lMeYG%(_}d|Nn7gD z*jdNIukL(J*p(Q+D^Xpa+F&+Lce@DHVz*1{!8TXcJ0prbv#>i4XPE?!qgGdDQ70V> zw(#ZGcwvB}ElUsN>n8h}ka$N=8_(zAT|f_dpRk5a2EKPahZVb6DBj{v~IO^#$R zuf&u_#or=(7b03^5Z!U5Ai6h8+tbw5pSvI`i^a7|v%Hs80E@FgOt$ans62O?_O*J| zw4-XxvXjhGh*`p9IY+Yy3DHHYVpA0Si3a{dUKRDO3aq#mS25OPc_ZO^sqzhclUni! zX;sjxe{9lTddh=;)xp;k!9Qf+zwN<4<={u+T%Xd66zpfE^c0Kt>J=BkQReHmQo3*_ zHiL@dPHdiIt4qlhsECF=4{vZTsgs|~ET*O9&G?CR0a5LhYV$Bl9O9ByMvwUv(mOAdlyK>};WcY3XTDQ|3M3t#YAu?0TfgWjr zz4KG0KJJ}=Ql7fAA86waFpH4L4N1~CUD1kY;Anz=HOV~2uE}Gep5#gVNdziLY*^!e z^@`TelXQ(44-!}On)2)X>g8TI3F6vOhEp3H z4Tzd^G$1(MeaD4>h7OW0821va2i;Ue$V?ng2m^2i8L^xl*PZPKJLF)}b6*y@im;d( z#=^B{IEaLRi_j_WnS)!~Go!CvMogXn7caq6_E_aliV>-{DVCWHomEH*R!?!Dd_gQL zAe&>b(^x>T0;tMc(dclum`+F<#}ln}G9n9!#}Njyi6~R)9`r+G+g*PZkPw#`g-K|- zr?*fN#2ZSZ=w}3`*s&f-voVRVQ_$5&fs4GzcDrl%m} zUadr7w0hyMLS^yok%%(j@e=-2k2uIMNkaWWXQ%yvCY_z2sX;Omq6fv&n`wa=4&{Jj zQRUDMJJ`; zOsZH@V+806p{Z5S4rrD9xuHZe3>CE4ea(M31Z^l$9S0Fl?Q}^bhf`Z}x=X_H$&u{e zybgCGxX4`8XPk{}EIwFb=UGb(evVq6v{HO>SD z;Sd&A?v`Ka)wap&i%q64{{0(XUzjSUqtwPi3jd`+DSQhmA%)AOUDX$n!oN2Z?jkL+ zf`!UR2x&BhXYLosQIOTd+{2CPn$1IN&W;b5iCyLKD2pQ-iQehasuQ%rgcfc>-{k1h zZ?9Mkj@Bf`kxrzZQXbdrZ7M;?c7N#B(13*E9)$m0;N!AIt^eWbx9)$?5W#*M&)mVQpTY*wa65VulT7Xf4IMKnm(s(G+=`7Z~+bHNvfuQ9q z56CI?nw*@?tid-y%6#Ji6oJ2rRYP)XHhjdGgeq zodGe^dZ?(x*f=>e_9$1iKP!mOVjCn`DlJSCclJ7nS6!W&EoNcn7s8%I)7WY=M$h1ty$Bhzo4IR5-{qTiieIe=3H zSPc)jzX&7D9Yd9r?ttN=V`q(Zf(B=eAH!3&4A_*YjMEafgxu6i)!aHXVCCiLB;h(_ zo{Otavw3*3b^k=02RQ>y??r{V#wf*-phM&-;mcLyD_p4!L`~FEhy;pDCoJF zu|aPX^%M`{$bARkV76r8NGPE{eyOZ%_PjGe;vX%hS(usmJieTH2Kl%?g~6ZH??6)a zqHC3h)2ld-w&5un+^SPzvL(4vpb8gyaJ4~#ypIHP7z0YzO45nx7MEaUB~q^06@!ZXSP%{MQS5cOFOwu{Lc6;z zBkd^u{|1`z_hx)KVN~GZjY_rm?GG z=|j1%Vo8Q8MJeqKBt$7aNo;^sIe$;Z`T{#NGx`C%YQMgKr)&n@sgsH#A$U?1lrI~~ z?{yCO;jks!F$j^}I95_%MEj;2*;w)(_?HMQtipVT?fcy#v=7gxV%mWAy&tdIzU_F* z{_rb?_VG0{;_G6WC2la+wGwGvS*l?Z*P+}g=z2nFU?2_1E#p~axSD+fP#36s4Uetz z+~g{&mE-{R-+&Me)1s0YXFzSr7EU+7+6^uEQ~3-sU}1kFtWT)5>dK$W``J8BHGku) zFai8_&=0~2-9vnd*>r}VlURO|mN7;;ld-kNNr$17dge3qtZg@v46tl5p7 zalF_WuG(Tam24vs#mT0aD#*9AwJx(t5XmU6IBB+Ur0_nq^&b~P*kO1G|If{gJ^=4r zjY#28;Iy(Y;3YHjFZh;yA8Z$h`8+YVSN?=!y0<tdI6X79OiCzf*BfWJ@_ zN9@+5lE;&{0w0V(gJ3S8a}hoQqROnWaj&_Qh>4B;Xp^1bfs3$Y_KLwIyktiH5(83r z5bHZ_II^0XiPA6+ELzC&CrmxqD5*<5T1TaudT^HfteP%AnJM_eglVGuWG3)qFkxDa z=hY8`G_p}6bDanfLMvv6 z2pzh!BR>ocvkQUT8oy!`#^e7MZZJHWalr4Ebva(TJFyq{c zE#vbV9&B@OOtDbdELp)bK9AvB5ne5((#5Eh2Y|TAjFXvhGzBEzm77E@7jLooi;(_~ z$v>qyKMzCaa!L=yMbApJ?6;Wqw5Dkbg0!7XyI<4TVd=6B*@M8?;7oa|iMMMcd%0u2 zN|AjNnexjzfGsu_+GF+ccIKd~FYdQ6Fjx)UmH(_coo&ct4``#C1Hjh^c#J7*4GLQ$ zg`qpl>=kOSx#?9sE(P7g7Hvl!K5_jrmb_2U&j=HySCQ&DkiBX zeugEbvh4LY?A-OpEXnsM8(Noskd%RnBk@djE|)FbZQ&jm?~eF9R_8GEai_&fel@;9 z^7p(L<$eEg*9gO3u~1ZbP-`a$cM>}Hg7o!WtYX5$5!4YbmeRMJ1pv!9dCjp z2#y)>!G>mp?mW%o!6vr z@HW172DTJ=TLVdGxqfZzJ6zEgu7{y6S`1@_Vj>#O@=98@pNjj!@`c!$6(ynl3+?DfppTAU~N2{D{3e zGvasRIq=`GOQe5OvjBP?RMbB0vhDC3KqJl5N(uR0jbQ;&y`HSr(kDJ5?{O)sdX)EMs=Joi=UbCF4 zqHCVCsTy`K6jbK+G7yB@R&1wezxZk_{vNF#icN8K;NcvjB*b)jS7Z<)2Q3o3s}_z_ zoH2FCpnaHAOu)9^tkW>BXv8~J6qh$soLj6Q0Wvce;V1jZxd!7*{Th_^T`6q@WZ$C# z#~ZYF8sJY;D)d0w|DB~sdADhKEi7;8vIq*?QA~lGhG-u&_0TkuZp*}P5~O8fHH(W1 zE6x!Dm@YgOB-nU%S()t1S|jUnfPe&F#ZR_lfhB=sf{}jnInaU$js>j81mBPn#!Zx; zX_5zjS)1#bM zgSindOT!=&td4Vg#4D9Ag~e!iJ{D!e>wi^)9-qUK)blN*13m=8QC7x%iW(@^{OtaC z_XO6{0jhab2Ydv&zl09RBp?Z@Fi`F&01j6NTs))>;4TiuKWY~zPBj1{N>sqzpJB7O zf72#U-Pz@57-jJFp_IWHqx3mPX10k}JbfF(9c0Oa8sw9!`xU&MPzA$)~IfPWW$vUg*0D_Bz@=$JH!PB<7@ zJe_bo3lg2s;uU$ZF5`u@;tz@mff+SbPXZFs@pDrhQ3%W-h`{_S~f&KSb(<&+a>jUMLmq{%z`o z$YS2MUKkI;Q7^nT$LNLO*#`T4q@-R5+XkPXI()sba7eviZ3C(v8HAre7A)EiVJI}i zABc^-5C)JK3QZ!a;$$JkY)JJ)4&O9C9M6Oeig_4GwxV2*V?KE%d2ZZmtSvK*z9-IrOt~6lIbHDElyvK7ZcI-QFy#(AJw5m zuaCYb^^7}Cex}_cKQnK}Pd0U>*T_hzZW&iXs$Q$;7JN;6~l zpXL?lgjE27PWS@W)Sr$%^nwrYg`D6#Btu7P{Xz}1#m zc6js@E$1AWJwJZHZ7_EINT}6ySeOe?5DI{`<}J- zbjI0*93HNXZxfsr(#0q5b^u#|{keDNX_lkUW zVFXFm7L$bgBpyjZYfElA!L_B`Jg7l+g>gmo%{0*!FV;DV7}MrG_!3&Sd=4K#lmEm| zwjATgFm%N-zD?1CEA6@MI_4YBQzlDZ;nL-YV}xHiOp+w#O8tXM*}>E#$5KQWyr|_p&+;C>c<4rm1F@`C zhzG7&uHZPYQ}<@SDZlTq&x)6oR-sf+()*>Zao?4n zX@8QRnJ?of`_e^Tb0a1FcNHZh{r|=#i%U;npLb_Zou^pus<4J(;6jAe$m zZ59lp%pw~>;=%_@7p?j6t@&}S`Mq27vDSQ5Ykp*Feh+j1%n(kg9cWhFJMlj0fXoGs zCD!}ouXA|IlyL+R2b8dHN!S4;N&gLT7-|0Cdw@s8CT-=%iC=eiFjx@TnAF*W5DD+w!KJ=aNlI#RLUVxS!)u`sKbFV!|yR_auB~HK=v)$Wn z@UBrjm_vtgL&80lJW3)S8FIkgJ4yn-i*BvRxh2by6Y(xYlciqlQ^(tffU3OcW5HRV zS;!gMz|PK8+MIs0(#G6Dtwco=;6w&zxEfpyPFFp;n#}O(s0dR_FV}NV1+mQE#bCJvtlX17>M*HYPK}o-6t+Jap)( z{uO*V^9*;UXevHu$LRE9O74_$;mW}&N+L=>lcIv~JEW*m@g|S7pm`y?lA`wkNlVcd z0eKfFs#W=02O*+|sft~>hE`DZriE4TI{N5wma3Jc<}PuC3TQfjCWg9^!C+x7Tsll*xnsquCljoF8?y0XYb_6Gtae_B@l&dtxk{{Z`=#yxLbea=E=-N$n=~Yt9-jF`IanqLatIFYP zC5MYdx48^C@uf(y+yLTH>Arb{DwY#=vv?XlM<$VpYFFMQxTheV6Lss@a(w0Tb)=fB zsu*_W%FhE2%MQ>g_SRG=G!s(lohmfkiy0_185po_T%t*n*rJ-%F`m;;1UTM5?I`c2Jv&dPs>FaE-7{F;%EQor zAsOhM=N^v|C*_mjrN=tq5a=La`tCx^iO$5-Dr3yEPtGk42vpsoKt~O8I%LS zroC{RaQowwL1->Uy^*uD#xqQZlLk2Va5&i}{_q@5zJg|9IN4u*W?sNXKBVhK@QL?^ zhfnFSfYF4*gJ8^XK!vEIH#nLVjx-!j7GXH)Vx*+JT&XmKLBCoJ`l~4KsRu>uQ`%)I z=|H%XpM|u!DX1-g$Wk{dm&01|_J@%>6b|se=InS8K=zbb8=l)7kXZe{m<#_~Ic0_s zo&`>Kr_6{%$YOo;7#&#dIFv`oZbOd}!4Sx|49GG8S>4olTiKGm0LXk)(usGIXDla`}&V&I*4v*QZJq@+OhsSsj41hd5#wX6ZmQ2(q9)f|lQoPwaMRn(g z!P5JE5bfa2C~ovA3CS= z1kdR#gT0nNz@F2oP5oI|oyT~Xyy840OZ~)88FI4d7E}m<=4lrmB2v28lom}yGZEdAgrF4gWI10{mhv>LYuzPT1CcGFCA8+-R8cW(x83oFD zpmE%MG?HfyPQ@=*=~5g9zRs3srd=mLGmrWZWML)*eDky(}Ju!Nfq#B_&%{B@Gg^1eusD;&% ztbzav!O77M|Kun#QnP?=?6tDo%UEf_&3n)s_}PTNR6vR|BB3=kzF-boB0xQ( zCy2(>BbNPuwfB#f=*ZS1wIf^b>pJqMctJ;Y$j{85;3vC#T063~CObPe_iMMHWJPNmejQqe zD_RFDTE9Y4_KVjSpoQ5osL(6NFZJ0{gr-jceKv|VUN;%)Y6AlG;`;T?oTSE+f4Tbb zRFAL+*U@WJuY}cO)9dB28&)E7{{8R_&X(7v{;JCHH7LjAld+Xo*n&61xZM~ZzD0` zCwQ+7DuPXe)Ek`0-T~a8m#T3=J8BTmNo6K*{SCLF{Y6;bRtih*h7Siz4G!`s#{%e1 zqIaA0wH&mpZ$EX{gKWSVj159G>FQH<1Q5y0+#NsJ(_fKJropVjGue=DHNGhB_`(5o zt=aZS#j$ds`<}vUjhu`pB70EEMT76;(_hFp=Z{R+j$Y?FeeTNb?a36I))PorW$CT;W(CCYn zFF_>9b_AktL-D7KqKDa>ZfBj8pPVHmzl}15|@os7@51;#^V+1z{tqA(`h5_gqYO z&2>n6#vOBuWk>C_Zeay(3E!1yrAoq@?gijl4OetOsF1z5U4(H$RFSsb@lIVGMaSko zNK>vAbJfrV3#rCF@H8TlG{AhS??hue4KMfOxj&d#*5P{WjdeSo!(ooT^vL9s2}}Xw zeVqSo&3%A8B0fn>tGnRIy7FfL*F(y0vrDG2Z*Pb_^rQqRb)Rat0jyWE#O~_>g}~UZ zjGx;wUUwO!jGv)8ti@>9)mZ%JBex}=j#LjsXkr5Q}BA?2JInL;wx;X1 z*3|Ee)z|M#)o*P=_4%(tFK*SV+o4F_KG8uXL-bxH`g=+A5cLp7Dswp&O#bHyZ%|qe z+9*nBHAny>L`Va~KdAiH6eOgipYUcN8LUiZ+1Eh9St{ipduMbffES(@rvlI!jyZQs{ywfG1 z)c_J89-6SsOX$Z(##lX9FM7zD*K_oB3sC6PYe(Ma9urjr0_2!@U;aowZ;`mU8VgpV znjeWO5TOfo^HK&A+O?0ceaaTI8)l#WX$)C)gT>jNlj^dzbbP{`)W+G5kRjPd&RJr1 zB|u+C2kQX(q1syoXx^w9+ZfG?s@z#En{i>{Zb-z{^9NkZ+Y@2>^JRv-VE-1En{Qr) zpKGT)!neO;6y2Qt;+&nk{vN9yz3yOsS+F7dg_95;>ItYP*xCpw!+<4y$XJh}rJz|_ z(2w6^-k0n9m)>XId1vKMhzA7wmJP2QRNmY4|Frk*@ljRR{wEAC6_S9c_^2G;0Wl^a zgm48(API@)MMxAXb{J+R$>?NemXw?~2uW zqxHe9Xt`>=p>S(dijO97?}T?z6-ci>N>a})Tc9R8-p3)C} zH$G7S(T<|Tn{`_K=C=Kt`f_^l{;*$i>92lHS!U`i`HAzu8H}Nt{o|=duOqv>$j1dq zPVXOoohEqP4`97fYyY&3`m7DTOkHIK=cl1TlD!vjENSsmnAD(7z{}SLqj{jFQo-`j zuTY3ibmqz*KgYxe)2?O)Z0eFDEE}(Qb}+fk$%I5e(MuZec4%4tQN`N8$99gc9Zmmn zyA)M62FO!=l!QKhnG<9dswRvjzX4g6u&6ZaFczf@a9IP6vi3vAy2e!2!0{FI5Xixw z-gLdRdhjpHwMNl{bScC*p6(l^BrqRrXc_m zorPIK%iK+Tdse&YpV+mwi9eqM*LgY8;5siN61j1z)-Twg%HTaeQ1=;L>t1bIYjL+_bBeA8zwmRX;XwfWzZhK4U=}h zH@EGy`>9ar&!GfTHdUG(+lbNa$+}v6dB%2oa+t)JpNrd*17m0e-3dR{tBAc&y&GLh zOH#GDKsl&!hhjSeGzv6w_l);_>$`U6kOwbs>ogvmlqu5=Mk978=p}+bFXA>) zAD@zaNjj0KPV)I}c}Vedy3aaUIz95qSB?jTv054NN#686IB6Q-I|WYK2-3FzxAlos zYvCQq)mvyup*QBYSa(jAYMsibJ0I;hhg(~1jm!SXW(`M%e!x6m@Ozoyv!VLP3w^Xi z`EI6DliKe*R9DeC#{0=y^XnSU( zt-rm5lE@qVJfPLzzQ6_g+oufX?l={~TrQvCHqqa(QG$sOc22`J41bU1MBQ^)^$xoe z_0LFG3%}tdFH$Af*-O4zmb^xmycVE;FFtNYn*o;lbQk63V_CbKwe6s6Ux8}R0!8yE@a$AOcY3Szl zaQm`^J*SMpQ}gPjqqR7@r@zyakC%>qV(*bWBEquw$%8fg0(Sr)IUuJu3(a)&S!)cC zS{cUYEU9j%gSi?7kawAeTSpE)npKa%z@By+nwRDQ8a(ALS^6;T981tV>LqPGH^Lj* z0KW&nTdua}$!@6u>g4K)F}dJaT-j2&sIpm(C3sn40SFr4biye3kN0xFsn}e7R}Nk+ z+m5jo2C3T$P1Kur$3!{evVmZ*;1f!GA_LXn=IE5=N`kEV#B0R=qCTCf`TtTiq)*yC z%&br8drGA_^*LSTL)XbZHrH?d0WE5vNUllGlj=YXDN?EqUnV=$unDe>7y3Wk${I6i zy?|Llt{0?tHQPSo`n~IL^)W#mxI2Wsw%wE_NCt_^7 zW)zk=&7;Vgi8)p&>cyv05ZevBVW#05st2N=vP&qqmb zhGiSbfg5FE24ANzNOw0It$x4Qp@rSmU?GQw#Q~P4Ww2(1!(3c zu0v(k!#yA?V=I8SvfxqPi*E51x3Xq|kF}Nck=)9neSX@?I&*j#O?^1PqkI-riALJ) z?`1(SKPill6a~ z7mYUcZE83$yUlXMCuSlix`Xug@`qLAd54i3H#Zz0mnA%4Ie0k%V>gvWumMwRr&UM|%?qY_m7?^1@HPz;UGDQ(Y|* zG~BntoYV&c_q2J>ymO7&1+_)oO z>XPI6Qq>&N4}JE_Zx%kNPzQlJC{Za-f%Aig>sZ(q`U68rEPD^2U(#`^=aJD#_n4xq z1RW^O8BXzpqL`v6=!NRzz(>0tRw3TYla#{p47D8Cr|noe;CA>5y<>qcB-4Xp7C9{0ujILl@L9v{>HfU^!m0 ze2m2FnK?$XoJ=gID3*ub<2pL{(zDO$e6MuyeUcfTa=GODQwDQ;0s3F4%^>PXZ0`?e z`8l4QPu0FvvOEkVM7=_?B)#^>EtVNu;tS+RwZ!}I$mo`Exn)bxl5X?0pTGEg`?gQ> z&i=CU>Uw;BdOB`Zv1j>aWn0~*KUKC?ZW?T>?YZOt(2MJ*4pA%jyNd=z?Q=t}_>|(e z^QNqWqKx`YpVV*qBTo2Lib=n#UH^Pe?d*3Fe?Z%ez2@4=WtG=fexuU;e0zIg-joeQ z4)5mKUp}uOTMj7cT8A8iZmqHSh(^Ov^MZgG_IeZ1sNZLwC`Wf&lB>Q-f&kW!Q}-) zaep)t4thdybCoBU@H5xHg)hsQS;)V=-oyEsPWj`Ve$!S5QVEB@RxgqNWj#mIOe0LjNlgfuPUyL?V7ztQilREBt0G;r04svGznzw+J=M zK|HNVp>N(lY$zeAz@A)2uXXequoWkmG^m>Ao@wmS$5+`m|)s^-2O$#bpt4;Ka zU@+|U#L;gqx*&ED(V4+O$ZwXF7MtOAvz_`9dXVfqh3&J8i~zB8`&NfS!I+)CBn!QR z+{S-KHhPPfq9WRZJOB>GBJZdq3B;1O*bp2 z1C9B{)8)r>V1^Q1D*%vCS3)VB9(1?qR3(IqJRvg>4Ej4T74eL5kvX+-L2K2*>V^iB z{;#5cD4@QrrK+`skoX6(wPkUGspZRD-&A{mMQcsT;ZX=OEiH@c7cHugNY)hRFI0wHs5KsSA&u?yQX=tl&s%~Cf zSKriFUtQCx>q_n08uf%?k#NkPLUODzY{qp`W0Tq1QrWl|H9;+Pq^hZhEX|6EJ|9aS)e(? zaDl$w-yY}d68dkRLHcf~;s3=*HmE#=G+6@m5&_~Re)Dd91;=0TTdGj+W||b4~e~i z4_6O~0l<&zhQwq%%6oYP^nklQ20h?apAU(90iPP36#D>A%1w%+fXOLIVPbh(d~QwHaRXrKO3(wodQVck z4EX1NPKqOdH$9XTOKo_j(2;g_d2{9S>Xy3*M zGAaN|CkwG0@Uzo}pc~ki&Jtn=;6zi1UcgWZ@&VRgF2p3=d;j88EM}gXVDfwCySO1iU?fE8ELPXV9~aM_Mf_- zw`}sBk&<^EXt#F{iu<$4duK{s+6|kyaZsED8_6icv6Q@YBIx702E`58AK-HJfl{^+3CP?Lo=Tw~EL1MRb)4vMea>(*dv=h{@=HiGuZh#@fr z{nL`cPCNcY=1cas8??V0HzY2`m}b$|_qeuOJ_32q?SDbE@UkchM<_(D&jKLP)#;vZNky}QsAMKhk5|m_%%Ru+)f+5jx zp^eUN=j9h#k6Cyur176jdN%#|(p^h`#+bHB#4#FOUlmZeECXdjz2&%?5x6J0Op zF2vUB?e=`e>2S`6}f)EQG{O4PB8i_UK6<7-{!%nm%r+s|7VxnaSMW9`Kp%Cxd=XPDEzSO+F z1aw7MHx}RsO-7!lp29r2{-B+X*J)bION{dOY#5%{G4#UcOWEI--iUZgL;o*CU6 zSY@TgfL$~n5#15cz1=Lt?{TouqSLa!b%rI+B+S9v@wVaz95(WQSf2&RT8i{3AtByJ z|FQVkZQvC-|4`kQgZ9lh&Z0SZ?Xuct9n!DI>k;2~q`zyGwFBve_-IdYwl&XLvX7En zw8o!-we@Le?~HPdNR7pxgZAt@gt+P4EVO}hSs%pre6)4sXF|McZ*zNn_oUjr88oN- z9QCocg`M^lY7IGW+yL5_pTpYSuE*4v@&;*<+HEK3w(Jw)9lMTnyGb+Waph&uRpQ2+=IX#t#a%-diw;c%pIT|zIYxkZ(^1@m*w`MHzl=jPAP9c$1{P$_J2JNRHq{d@Sk2L7&r3>t`>Cy_-8 z(vU$R9flM_PD zs%3Pm1iD3~po%kaFqy+HRdJ0UPz7nZdlelGr4)4ev`nR->2Sh<>j(8R3a2Ib+ED!9 z2jy!i9mZUBeZQ*c7wTHqLvsJ$`|nomlFqTrl$aU?uTrpG!Bq-=OToJpykEhm6#Q2O z-&F8J1&=8>`W%D9sR~}GV3~q73SOmPyMn6}{FZ`uD|o+xPbv7X3cjh}hYB83a5Sw$ z5KdL_LIukdtWoeP1=|%|rJ&6H)&Iwux}}|YavYZf^V0W4RdR(B4$K=mIs#cEc!es3 zT@?(BNTr0S|MfR7Sv}!|eB*on@6jb6ANc6zO$}$i@y>`Hb0pj~N38i#^T}1ev3%}M zc?|BC)ED*7M4W0e0>3Hv!H#dHIQ4^D=>l*jej^5P0pne`V8K6_1#K%5p?JcaU07OJ zbV+f7uZnLfDJm=~ohq@&@)v^(quGO0SXyvFn!OqEE~7sqexyPEr}W@LZS{C#PjjL6 zdR%hi#~8Z5I`Qc8dVsPexQr7FJ)YRm@ROft=yAu12NTndk#QGBXEP&yys_@wO!T?N zwv6~ZYdp8-a?z@5V7P)@#ss7Ji%j^5M*d(X{K?k*;N(Banirh-Q;baGlFK;N8poaV zr$Il%`<08Vk>1Ii7F^b>l}aFcA8C9nQWzPdX<&qrYxJh+ja(OmA4tQWqwsqEm0aLE zKqSW|50yuu2EQD5?e+Y~Nc?r-NBs4CuJLOS$uWlOb35>v&NId(Ofg6KMqJJ%4;@L+G{A7hM`~(*W?7Ide zwnYB`JDUuHeb2y`D*T@>mwebK41A@gzjOqypmzz3B?|v;u|%+s5$WUyBmP?hk`McV zfxlhhrCuNmW{rxS`)?r8i|VBaqwJ&H_t zy!?gn>}y7By29W8vBWPY14LK|e5Q7920jO?8B_HO-3zW^{A6RS>KA&Q(xLGAY50|j zPl4j2>DMZJQ5t@|!k4F&OK*lE`=6Y~pVpZqXGI#H`xL#IM*pb77o_3;Me(Uk4Z zx1CE|4C7J>jQbUzyGc<9?E3Ts{Bt104eI&j79lp7c|jrk}eNeN~^7 zpM991|DnP!q?dId@V*M*j~UM>$KNwq@cXmi$KVDblb-4P3)#u5#gaXrDL{0Z!k_aS zDJT0-fiF?`>8m6?@6#iCWfuNkMgQ7ulAibK5nZeBkG?7Svkw*cTeI-_De$Ib;rM?E z_zAZ4Fq)ggZy7(?Xin4rG3JkT(F9p8@1Y>a5aU&58>JiIXrpGO#cVXB z4~ow#^y)#G#JP4OAJPU85C3Zmat_zl-d`FWoh z_#Y|$>HdO86n#XE^L|yt9)*AVDk&%LH6e}m=&0X)?U>}x`-{N;O5u0@UedFlANbc8 zubA4vAAzTFW=Wczp9lw7rgkZ0e6H~&Ei4gupB%7E;iug#%jJC_;OPkyl5^ctlAiac zfv?HJ{~KBGu`KxSD*k^yBKh+^F8KdY;qRR#<>7rp;C~E!KI)s^zCTm+d+R0rjvNpp zJfrZB%$5B4tO4-9Q1~@_B|Yy?0sjKyDW@~Mujs#=Bk_Em3emwV^b_DG%w*3O08jdS z_F`Es@0)_pbcIiTUCPPl9Dtv}cv+_Xe`yx{x3l2CulNtXA3Kw9hQ1f z>M;5g{=ugup7(4~?tX<|bDor+&mJQBj>4C#brGKh0saGpzv7#c5ARx8*jzVSm zGfQCkd_k|BTvo#! z^oQK2P?v)myrXWTu!CgxMg#Ex1_E~?1|*&rO?cg~1HGde@k}Rb z=TK$PvoZqB`+}Zmdxu-ux!V^FV}vw(N^uKGAy!EtQaiH*FRdz{r#rF+IaY^)@#4(F zc{}~y>)in;faQypP_Z$801d-W?Kve=x|gDNc>*D4G8Y^SqrpSr5b79?heH889J>b6 z0ouhYg~0 zAWu7*i5OBFu14ee!6{`3?z+|nJmIV7sn&)CG)uL5Rs{WqyRHfK@&!WF*1qGkKgPdM zv5}ZPss9 z-P?($$hmX8)gf}vv8}?fm35qdm`j@$GHj6uj1`ww>0+>4H`%dk#?c&)<@&WFbm;+5~K0K z?Tdxoop@%M8aOrF&?rh4=?|?!X}&P(MP*0ZRsCWZ#4zB} zNG`RoA{J9N6YzPuJl!Nh3?qXt3`0hzbWYg6HxEtO z&7{P@L`s93y|eqNOJ`uoyix+`)^-Y%wji|WpZb-WeIpIE;nfI*f~ zmGkQ^iF-OQ0MS>=z$@L;mz!i_X6#ypfk#UjDDQOF&<5K*)R zF5@s4qmXVWKon+u7y3KZEkvgeO!Sq^D(@v^4jor>A7rBDDnyqu3UMDpuY!>GME{e2 zI=4l4jOw=5I$xpBS?F_Hx(wy^(3b|?-obTe<=5vhG(6v;lo9Pe)#x%r?D_S14Gm3A zs9<{jD&X;WU0BPn&vj_1%ZJ;V1Ke4T(1h8^F<7Fr8nYC()4jQ_%8jIt{N!8l5fE*IXIOK$Sumkbuwc zP*t@23T>=Kgz!4QKA)mtuOigt>-@U@8&v-JicX(n(Xd<9pYorIUwZznz>!W!zZ^^_ z)aMEnmSxp(f}8NO=QmBl8rJ!k<+@@LO`d!X8s3E~dwzX>Mnf&H%4W&0@jpn*ulK_= zZ2Ps-0Cc&U-+gKM_4!H-^|?z;ugpUSDhY259o|)A{vzn#fno z{~yRpwx{#!^GDq(zo`_X?NgVl^+@~Wq(7ZspEuo}E9LK`L|f4LHT(n8?D-Aa=%qjp zrc+4EZ!$9VH-ISd(&bxz>j|p-6e-7axf=Z^M5u@&jnGi#pQ^7F)Z*BowjDcZk;-47 w4%$*bUV@)4UymPTo|f!321_oG@}FQGM3#xVTunM5OMXwW%%9YR3a01(Zxq{=cK`qY diff --git a/extras/c_binding/test_install.c b/extras/c_binding/test_install.c deleted file mode 100644 index 2bcaa1f..0000000 --- a/extras/c_binding/test_install.c +++ /dev/null @@ -1,149 +0,0 @@ -#include -#include -#include -#include "delsparse.h" - -int main() { - // Set the problem dimensions - int n = 50, d = 5, m = 10, ir = 2; - - // Generate random data in the unit cube - double data[n*d]; - for (int i = 0; i < n*d; i++) - data[i] = rand(); - - // Generate interpolation points - double interp[m*d]; - for (int i = 0; i < m*d; i++) - interp[i] = 0.25 + 0.5 * rand(); - - // Generate response values - double interp_in[n*ir]; - for (int i = 0; i < n*ir; i++) - interp_in[i] = rand(); - - // Allocate the output arrays - int simps[m*(d+1)], ierr[m]; - double weights[m*(d+1)], interp_out[m*ir], rnorm[m]; - - // Set the optional input parameters - bool chain = false, exact = true; - int ibudget = 10000, pmode = 1; - double eps = 0.00000001, extrap = 0.1; - - // Call the serial C interface with no options - c_delaunaysparses(&d, &n, data, &m, interp, simps, weights, ierr); - - // Check for errors - for (int i = 0; i < m; i++) { - if (ierr[i] > 2) { - printf("Error %i occurred while testing c_delaunaysparses" - " with no optional arguments\n\n", - ierr[i]); - return -1; - } - } - - // Call the serial C interface and compute interpolant values - c_delaunaysparses_interp(&d, &n, data, &m, interp, simps, weights, ierr, - &ir, interp_in, interp_out); - - // Check for errors - for (int i = 0; i < m; i++) { - if (ierr[i] > 2) { - printf("Error %i occurred while testing c_delaunaysparses" - " and computing interpolant values\n\n", ierr[i]); - return -1; - } - } - - // Call the serial C interface with optional inputs - c_delaunaysparses_opts(&d, &n, data, &m, interp, simps, weights, ierr, - &eps, &extrap, rnorm, &ibudget, &chain, &exact); - - // Check for errors - for (int i = 0; i < m; i++) { - if (ierr[i] > 2) { - printf("Error %i occurred while testing c_delaunaysparses" - " with optional arguments\n\n", ierr[i]); - return -1; - } - } - - // Call the serial C interface with optional inputs and interpolation - c_delaunaysparses_interp_opts(&d, &n, data, &m, interp, simps, weights, - ierr, &ir, interp_in, interp_out, &eps, - &extrap, rnorm, &ibudget, &chain, &exact); - - // Check for errors - for (int i = 0; i < m; i++) { - if (ierr[i] > 2) { - printf("Error %i occurred while testing c_delaunaysparses" - " with optional arguments and computing the interpolant\n\n", - ierr[i]); - return -1; - } - } - - - // Call the parallel C interface with no options - c_delaunaysparsep(&d, &n, data, &m, interp, simps, weights, ierr); - - // Check for errors - for (int i = 0; i < m; i++) { - if (ierr[i] > 2) { - printf("Error %i occurred while testing c_delaunaysparsep" - " with no optional arguments\n\n", - ierr[i]); - return -1; - } - } - - // Call the parallel C interface and compute interpolant values - c_delaunaysparsep_interp(&d, &n, data, &m, interp, simps, weights, ierr, - &ir, interp_in, interp_out); - - // Check for errors - for (int i = 0; i < m; i++) { - if (ierr[i] > 2) { - printf("Error %i occurred while testing c_delaunaysparsep" - " and computing interpolant values\n\n", ierr[i]); - return -1; - } - } - - // Call the parallel C interface with optional inputs - c_delaunaysparsep_opts(&d, &n, data, &m, interp, simps, weights, ierr, - &eps, &extrap, rnorm, &ibudget, &chain, &exact, - &pmode); - - // Check for errors - for (int i = 0; i < m; i++) { - if (ierr[i] > 2) { - printf("Error %i occurred while testing c_delaunaysparsep" - " with optional arguments\n\n", ierr[i]); - return -1; - } - } - - // Call the parallel C interface with optional inputs and interpolation - c_delaunaysparsep_interp_opts(&d, &n, data, &m, interp, simps, weights, - ierr, &ir, interp_in, interp_out, &eps, - &extrap, rnorm, &ibudget, &chain, &exact, - &pmode); - - // Check for errors - for (int i = 0; i < m; i++) { - if (ierr[i] > 2) { - printf("Error %i occurred while testing c_delaunaysparsep" - " with optional arguments and computing the interpolant\n\n", - ierr[i]); - return -1; - } - } - - - // If we made it this far, the build was successful - printf("The build appears to be successful\n\n"); - return 0; -} diff --git a/extras/delsparsepy/LICENSE b/extras/delsparsepy/LICENSE deleted file mode 100644 index 00ce8f0..0000000 --- a/extras/delsparsepy/LICENSE +++ /dev/null @@ -1,22 +0,0 @@ -MIT License - -Copyright (c) 2020 Tyler H. Chang, Layne T. Watson, Thomas C. H. Lux, -Ali R. Butt, Kirk W. Cameron, and Yili Hong. - -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, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -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. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. diff --git a/extras/delsparsepy/README b/extras/delsparsepy/README deleted file mode 100644 index f5bba7f..0000000 --- a/extras/delsparsepy/README +++ /dev/null @@ -1,44 +0,0 @@ -A Python3 wrapper for the DELAUNAYSPARSE Fortran package. - - -REQUIREMENTS: - - Python3.6+ with numpy package installed. - A Fortran compiler that supports BIND(C) and compiling shared objects. - The Python wrapper builds ".so" objects, and therefore only supports - Mac and Linux systems. - -USAGE: - - Update the configuration of the machine-specific Fortran compiler - and BLAS / LAPACK link commands (or use local blas.f lapack.f) - in the file "delsparse.py". - - Now, in Python3.6+ code the Fortran package can be accessed by - - import delsparse - - with accompanying documentation built-in through the `help` command - - help(delsparse) - - and it is assumed that Fortran-contiguous NumPy arrays will be the - vessel for data entering and exiting the Fortran module. An example - Python script is provided in `example.py`. That script also defines a - convenience wrapper that converts C-style (row major) sets of points - into Fortran-style (column major) sets of points. - -CONTRIBUTORS: - - Thomas Lux, tchlux@vt.edu - Tyler Chang, tchang@anl.gov - -ACKNOWLEDGEMENT: - - This Python3 wrapper was partially generated using fmodpy. - - If you are interested in automatically generating Python wrappers for - modern Fortran code, please consider visiting: - - https://github.com/tchlux/fmodpy - diff --git a/extras/delsparsepy/delsparse.py b/extras/delsparsepy/delsparse.py deleted file mode 100644 index 3414f65..0000000 --- a/extras/delsparsepy/delsparse.py +++ /dev/null @@ -1,759 +0,0 @@ -# Python wrapper for DELAUNAYSPARSE using C interface. -import os -import ctypes -import numpy as np - -# -------------------------------------------------------------------- -# CONFIGURATION -# -fort_compiler = "gfortran" -shared_object_name = "delsparse_clib.so" -source_dir = os.path.abspath(os.path.dirname(__file__)) -path_to_lib = os.path.join(source_dir, shared_object_name) -compile_options = "-fPIC -shared -O3 -fopenmp -std=legacy" -# ^^ 'fPIC' and 'shared' are required. 'O3' is for speed and 'fopenmp' -# is necessary for supporting CPU parallelism during execution. -blas_lapack = "-lblas -llapack" -blas_lapack = "blas.f lapack.f" -# ^^ Use a local BLAS and LAPACK if available by commenting the second line -# above. The included "blas.f" and "lapack.f" are known to cause error 71 -# during extrapolation, but there is no known resolution. -ordered_dependencies = "real_precision.f90 slatec.f delsparse.f90 delsparse_bind_c.f90" -# -# -------------------------------------------------------------------- - - -# Try to import the existing object. If that fails, recompile and then try. -try: - delsparse_clib = ctypes.CDLL(path_to_lib) -except: - # Remove the shared object if it exists, because it is faulty. - if os.path.exists(shared_object_name): - os.remove(shared_object_name) - # Warn the user if they are using a local blas and lapack that - # this is known to cause extrapolation errors. - if (blas_lapack == "blas.f lapack.f"): - import warnings - warnings.warn("\n The provided 'blas.f' and 'lapack.f' are known to cause extrapolation errors."+ - "\n Consider using local libraries via compiler flags instead (see config"+ - "\n coments for 'blas_lapack' in '"+os.path.join(path_to_lib,__file__)+"').") - # Compile a new shared object. - command = " ".join([fort_compiler, compile_options, blas_lapack, - ordered_dependencies, "-o", path_to_lib]) - print("Running command") - print(" ", command) - os.system(command) - # Remove all ".mod" files that were created to reduce clutter. - all_mods = [f for f in os.listdir(os.curdir) if f[-4:] == ".mod"] - for m in all_mods: os.remove(m) - -# Import the shared object file as a C library with ctypes. -delsparse_clib = ctypes.CDLL(path_to_lib) - -def delaunaysparses(d, n, pts, m, q, simps, weights, ierr, interp_in=None, interp_out=None, eps=None, extrap=None, rnorm=None, ibudget=None, chain=None, exact=None): - '''! This is a serial implementation of an algorithm for efficiently performing -! interpolation in R^D via the Delaunay triangulation. The algorithm is fully -! described and analyzed in -! -! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. -! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate -! interpolation in arbitrary dimension via the Delaunay triangulation. In -! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, -! USA. Article 12, 8 pages. -! -! -! On input: -! -! D is the dimension of the space for PTS and Q. -! -! N is the number of data points in PTS. -! -! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the -! coordinates of a single data point in R^D. -! -! M is the number of interpolation points in Q. -! -! Q(1:D,1:M) is a real valued matrix with M columns, each containing the -! coordinates of a single interpolation point in R^D. -! -! -! On output: -! -! PTS and Q have been rescaled and shifted. All the data points in PTS -! are now contained in the unit hyperball in R^D, and the points in Q -! have been shifted and scaled accordingly in relation to PTS. -! -! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns -! in PTS) for the D+1 vertices of the Delaunay simplex containing each -! interpolation point in Q. -! -! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each -! point in Q as a convex combination of the D+1 corresponding vertices -! in SIMPS. -! -! IERR(1:M) contains integer valued error flags associated with the -! computation of each of the M interpolation points in Q. The error -! codes are: -! -! 00 : Succesful interpolation. -! 01 : Succesful extrapolation (up to the allowed extrapolation distance). -! 02 : This point was outside the allowed extrapolation distance; the -! corresponding entries in SIMPS and WEIGHTS contain zero values. -! -! 10 : The dimension D must be positive. -! 11 : Too few data points to construct a triangulation (i.e., N < D+1). -! 12 : No interpolation points given (i.e., M < 1). -! 13 : The first dimension of PTS does not agree with the dimension D. -! 14 : The second dimension of PTS does not agree with the number of points N. -! 15 : The first dimension of Q does not agree with the dimension D. -! 16 : The second dimension of Q does not agree with the number of -! interpolation points M. -! 17 : The first dimension of the output array SIMPS does not match the number -! of vertices needed for a D-simplex (D+1). -! 18 : The second dimension of the output array SIMPS does not match the -! number of interpolation points M. -! 19 : The first dimension of the output array WEIGHTS does not match the -! number of vertices for a a D-simplex (D+1). -! 20 : The second dimension of the output array WEIGHTS does not match the -! number of interpolation points M. -! 21 : The size of the error array IERR does not match the number of -! interpolation points M. -! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. -! 23 : The first dimension of INTERP_IN does not match the first -! dimension of INTERP_OUT. -! 24 : The second dimension of INTERP_IN does not match the number of -! data points PTS. -! 25 : The second dimension of INTERP_OUT does not match the number of -! interpolation points M. -! 26 : The budget supplied in IBUDGET does not contain a positive -! integer. -! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. -! 28 : The size of the RNORM output array does not match the number of -! interpolation points M. -! -! 30 : Two or more points in the data set PTS are too close together with -! respect to the working precision (EPS), which would result in a -! numerically degenerate simplex. -! 31 : All the data points in PTS lie in some lower dimensional linear -! manifold (up to the working precision), and no valid triangulation -! exists. -! 40 : An error caused DELAUNAYSPARSES to terminate before this value could -! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may -! contain garbage values. -! -! 50 : A memory allocation error occurred while allocating the work array -! WORK. -! -! 60 : The budget was exceeded before the algorithm converged on this -! value. If the dimension is high, try increasing IBUDGET. This -! error can also be caused by a working precision EPS that is too -! small for the conditioning of the problem. -! -! 61 : A value that was judged appropriate later caused LAPACK to encounter a -! singularity. Try increasing the value of EPS. -! -! 70 : Allocation error for the extrapolation work arrays. -! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection -! of an extrapolation point onto the convex hull. -! 72 : The SLATEC subroutine DWNNLS has reported a usage error. -! -! The errors 72, 80--83 should never occur, and likely indicate a -! compiler bug or hardware failure. -! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. -! 81 : The LAPACK subroutine DGETRF has reported an illegal value. -! 82 : The LAPACK subroutine DGETRS has reported an illegal value. -! 83 : The LAPACK subroutine DORMQR has reported an illegal value. -! -! -! Optional arguments: -! -! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of -! the data points in PTS on input. The first dimension of INTERP_IN is -! inferred to be the dimension of these response vectors, and the -! second dimension must match N. If present, the response values will -! be computed for each interpolation point in Q, and stored in INTERP_OUT, -! which therefore must also be present. If both INTERP_IN and INTERP_OUT -! are omitted, only the containing simplices and convex combination -! weights are returned. -! -! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each -! interpolation point in Q on output. The first dimension of INTERP_OUT -! must match the first dimension of INTERP_IN, and the second dimension -! must match M. If present, the response values at each interpolation -! point are computed as a convex combination of the response values -! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing -! that interpolation point. Therefore, if INTERP_OUT is present, then -! INTERP_IN must also be present. If both are omitted, only the -! simplices and convex combination weights are returned. -! -! EPS contains the real working precision for the problem on input. By default, -! EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff for the -! machine. In general, any values that differ by less than EPS are judged -! as equal, and any weights that are greater than -EPS are judged as -! nonnegative. EPS cannot take a value less than the default value of -! \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, the default -! value will be used instead automatically. -! -! EXTRAP contains the real maximum extrapolation distance (relative to the -! diameter of PTS) on input. Interpolation at a point outside the convex -! hull of PTS is done by projecting that point onto the convex hull, and -! then doing normal Delaunay interpolation at that projection. -! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) -! units outside the convex hull of PTS will not be done and an error code -! of 2 will be returned. Note that computing the projection can be -! expensive. Setting EXTRAP=0 will cause all extrapolation points to be -! ignored without ever computing a projection. By default, EXTRAP=0.1 -! (extrapolate by up to 10% of the diameter of PTS). -! -! RNORM(1:M) contains the real unscaled projection (2-norm) distances from -! any projection computations on output. If not present, these distances -! are still computed for each extrapolation point, but are never returned. -! -! IBUDGET on input contains the integer budget for performing flips while -! iterating toward the simplex containing each interpolation point in -! Q. This prevents DELAUNAYSPARSES from falling into an infinite loop when -! an inappropriate value of EPS is given with respect to the problem -! conditioning. By default, IBUDGET=50000. However, for extremely -! high-dimensional problems and pathological inputs, the default value -! may be insufficient. -! -! CHAIN is a logical input argument that determines whether a new first -! simplex should be constructed for each interpolation point -! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." -! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not -! recommended, unless the size of the triangulation is relatively small -! or the interpolation points are known to be tightly clustered. -! -! EXACT is a logical input argument that determines whether the exact -! diameter should be computed and whether a check for duplicate data -! points should be performed in advance. When EXACT=.FALSE., the -! diameter of PTS is approximated by twice the distance from the -! barycenter of PTS to the farthest point in PTS, and no check is -! done to find the closest pair of points, which could result in hard -! to find bugs later on. When EXACT=.TRUE., the exact diameter is -! computed and an error is returned whenever PTS contains duplicate -! values up to the precision EPS. By default EXACT=.TRUE., but setting -! EXACT=.FALSE. could result in significant speedup when N is large. -! It is strongly recommended that most users leave EXACT=.TRUE., as -! setting EXACT=.FALSE. could result in input errors that are difficult -! to identify. Also, the diameter approximation could be wrong by up to -! a factor of two. -! -! -! Subroutines and functions directly referenced from BLAS are -! DDOT, DGEMV, DNRM2, DTRSM, -! and from LAPACK are -! DGEQP3, DGETRF, DGETRS, DORMQR. -! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its -! SLATEC dependencies have been slightly edited to comply with the Fortran -! 2008 standard, with all print statements and references to stderr being -! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 -! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS -! Algorithm 777) is used for the real data type. The REAL_PRECISION module, -! DELAUNAYSPARSES, and DWNNLS and its dependencies comply with the Fortran -! 2008 standard. -! -! Primary Author: Tyler H. Chang -! Last Update: March, 2020 -!''' - - # Setting up "d" - d = ctypes.c_int(d) - - # Setting up "n" - n = ctypes.c_int(n) - - # Setting up "m" - m = ctypes.c_int(m) - - # Setting up "pts" - pts_local = np.asarray(pts, dtype=ctypes.c_double) - pts_dim_1 = ctypes.c_int(pts_local.shape[0]) - pts_dim_2 = ctypes.c_int(pts_local.shape[1]) - - # Setting up "q" - q_local = np.asarray(q, dtype=ctypes.c_double) - q_dim_1 = ctypes.c_int(q_local.shape[0]) - q_dim_2 = ctypes.c_int(q_local.shape[1]) - - # Setting up "simps" - simps_local = np.asarray(simps, dtype=ctypes.c_int) - simps_dim_1 = ctypes.c_int(simps_local.shape[0]) - simps_dim_2 = ctypes.c_int(simps_local.shape[1]) - - # Setting up "weights" - weights_local = np.asarray(weights, dtype=ctypes.c_double) - weights_dim_1 = ctypes.c_int(weights_local.shape[0]) - weights_dim_2 = ctypes.c_int(weights_local.shape[1]) - - # Setting up "ierr" - ierr_local = np.asarray(ierr, dtype=ctypes.c_int) - # In accordance with how the Fortran code might be normally used, - # and mathematical notation, grabbing the last dimension allows - # ierr to be passed as a column vector instead of a flat vector. - ierr_dim_1 = ctypes.c_int(ierr_local.shape[-1]) - - # Setting up "interp_in" - interp_in_present = ctypes.c_bool(True) - interp_in_dim_1 = ctypes.c_int(0) - interp_in_dim_2 = ctypes.c_int(0) - if (interp_in is None): - interp_in_present = ctypes.c_bool(False) - interp_in = np.zeros(shape=(1,1), dtype=ctypes.c_double, order='F') - elif (type(interp_in) == bool) and (interp_in): - interp_in = np.zeros(shape=(1,1), dtype=ctypes.c_double, order='F') - interp_in_dim_1 = ctypes.c_int(interp_in.shape[0]) - interp_in_dim_2 = ctypes.c_int(interp_in.shape[1]) - elif (not np.asarray(interp_in).flags.f_contiguous): - raise(Exception("The numpy array given as argument 'interp_in' was not f_contiguous.")) - else: - interp_in_dim_1 = ctypes.c_int(interp_in.shape[0]) - interp_in_dim_2 = ctypes.c_int(interp_in.shape[1]) - interp_in_local = np.asarray(interp_in, dtype=ctypes.c_double) - - # Setting up "interp_out" - interp_out_present = ctypes.c_bool(True) - interp_out_dim_1 = ctypes.c_int(0) - interp_out_dim_2 = ctypes.c_int(0) - if (interp_out is None): - interp_out_present = ctypes.c_bool(False) - interp_out = np.zeros(shape=(1,1), dtype=ctypes.c_double, order='F') - elif (type(interp_out) == bool) and (interp_out): - interp_out = np.zeros(shape=(1,1), dtype=ctypes.c_double, order='F') - interp_out_dim_1 = ctypes.c_int(interp_out.shape[0]) - interp_out_dim_2 = ctypes.c_int(interp_out.shape[1]) - elif (not np.asarray(interp_out).flags.f_contiguous): - raise(Exception("The numpy array given as argument 'interp_out' was not f_contiguous.")) - else: - interp_out_dim_1 = ctypes.c_int(interp_out.shape[0]) - interp_out_dim_2 = ctypes.c_int(interp_out.shape[1]) - interp_out_local = np.asarray(interp_out, dtype=ctypes.c_double) - - # Setting up "eps" - eps_present = ctypes.c_bool(True) - if (eps is None): - eps_present = ctypes.c_bool(False) - eps = 1 - eps_local = ctypes.c_double(eps) - - # Setting up "extrap" - extrap_present = ctypes.c_bool(True) - if (extrap is None): - extrap_present = ctypes.c_bool(False) - extrap = 1 - extrap_local = ctypes.c_double(extrap) - - # Setting up "rnorm" - rnorm_present = ctypes.c_bool(True) - rnorm_dim_1 = ctypes.c_int(0) - if (rnorm is None): - rnorm_present = ctypes.c_bool(False) - rnorm = np.zeros(shape=(1), dtype=ctypes.c_double, order='F') - elif (type(rnorm) == bool) and (rnorm): - # In accordance with how the Fortran code might be normally used, - # and mathematical notation, grabbing the last dimension allows - # rnorm to be passed as a column vector instead of a flat vector. - rnorm = np.zeros(shape=(1), dtype=ctypes.c_double, order='F') - rnorm_dim_1 = ctypes.c_int(rnorm.shape[-1]) - elif (not np.asarray(rnorm).flags.f_contiguous): - raise(Exception("The numpy array given as argument 'rnorm' was not f_contiguous.")) - else: - # In accordance with how the Fortran code might be normally used, - # and mathematical notation, grabbing the last dimension allows - # rnorm to be passed as a column vector instead of a flat vector. - rnorm_dim_1 = ctypes.c_int(rnorm.shape[-1]) - rnorm_local = np.asarray(rnorm, dtype=ctypes.c_double) - - # Setting up "ibudget" - ibudget_present = ctypes.c_bool(True) - if (ibudget is None): - ibudget_present = ctypes.c_bool(False) - ibudget = 1 - ibudget_local = ctypes.c_int(ibudget) - - # Setting up "chain" - chain_present = ctypes.c_bool(True) - if (chain is None): - chain_present = ctypes.c_bool(False) - chain = 1 - chain_local = ctypes.c_bool(chain) - - # Setting up "exact" - exact_present = ctypes.c_bool(True) - if (exact is None): - exact_present = ctypes.c_bool(False) - exact = 1 - exact_local = ctypes.c_bool(exact) - - # Call C-accessible Fortran wrapper. - delsparse_clib.c_delaunaysparses(ctypes.byref(d), ctypes.byref(n), ctypes.byref(pts_dim_1), ctypes.byref(pts_dim_2), ctypes.c_void_p(pts_local.ctypes.data), ctypes.byref(m), ctypes.byref(q_dim_1), ctypes.byref(q_dim_2), ctypes.c_void_p(q_local.ctypes.data), ctypes.byref(simps_dim_1), ctypes.byref(simps_dim_2), ctypes.c_void_p(simps_local.ctypes.data), ctypes.byref(weights_dim_1), ctypes.byref(weights_dim_2), ctypes.c_void_p(weights_local.ctypes.data), ctypes.byref(ierr_dim_1), ctypes.c_void_p(ierr_local.ctypes.data), ctypes.byref(interp_in_present), ctypes.byref(interp_in_dim_1), ctypes.byref(interp_in_dim_2), ctypes.c_void_p(interp_in_local.ctypes.data), ctypes.byref(interp_out_present), ctypes.byref(interp_out_dim_1), ctypes.byref(interp_out_dim_2), ctypes.c_void_p(interp_out_local.ctypes.data), ctypes.byref(eps_present), ctypes.byref(eps_local), ctypes.byref(extrap_present), ctypes.byref(extrap_local), ctypes.byref(rnorm_present), ctypes.byref(rnorm_dim_1), ctypes.c_void_p(rnorm_local.ctypes.data), ctypes.byref(ibudget_present), ctypes.byref(ibudget_local), ctypes.byref(chain_present), ctypes.byref(chain_local), ctypes.byref(exact_present), ctypes.byref(exact_local)) - - # Return final results, 'INTENT(OUT)' arguments only. - return np.asarray(pts_local), np.asarray(q_local), np.asarray(simps_local), np.asarray(weights_local), np.asarray(ierr_local), (np.asarray(interp_out_local) if interp_out_present else None), (np.asarray(rnorm_local) if rnorm_present else None) - - -# ---------------------------------------------- -# Wrapper for the Fortran subroutine DELAUNAYSPARSEP - -def delaunaysparsep(d, n, pts, m, q, simps, weights, ierr, interp_in=None, interp_out=None, eps=None, extrap=None, rnorm=None, ibudget=None, chain=None, exact=None, pmode=None): - '''! This is a parallel implementation of an algorithm for efficiently performing -! interpolation in R^D via the Delaunay triangulation. The algorithm is fully -! described and analyzed in -! -! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. -! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate -! interpolation in arbitrary dimension via the Delaunay triangulation. In -! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, -! USA. Article 12, 8 pages. -! -! -! On input: -! -! D is the dimension of the space for PTS and Q. -! -! N is the number of data points in PTS. -! -! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the -! coordinates of a single data point in R^D. -! -! M is the number of interpolation points in Q. -! -! Q(1:D,1:M) is a real valued matrix with M columns, each containing the -! coordinates of a single interpolation point in R^D. -! -! -! On output: -! -! PTS and Q have been rescaled and shifted. All the data points in PTS -! are now contained in the unit hyperball in R^D, and the points in Q -! have been shifted and scaled accordingly in relation to PTS. -! -! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns -! in PTS) for the D+1 vertices of the Delaunay simplex containing each -! interpolation point in Q. -! -! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each -! point in Q as a convex combination of the D+1 corresponding vertices -! in SIMPS. -! -! IERR(1:M) contains integer valued error flags associated with the -! computation of each of the M interpolation points in Q. The error -! codes are: -! -! 00 : Succesful interpolation. -! 01 : Succesful extrapolation (up to the allowed extrapolation distance). -! 02 : This point was outside the allowed extrapolation distance; the -! corresponding entries in SIMPS and WEIGHTS contain zero values. -! -! 10 : The dimension D must be positive. -! 11 : Too few data points to construct a triangulation (i.e., N < D+1). -! 12 : No interpolation points given (i.e., M < 1). -! 13 : The first dimension of PTS does not agree with the dimension D. -! 14 : The second dimension of PTS does not agree with the number of points N. -! 15 : The first dimension of Q does not agree with the dimension D. -! 16 : The second dimension of Q does not agree with the number of -! interpolation points M. -! 17 : The first dimension of the output array SIMPS does not match the number -! of vertices needed for a D-simplex (D+1). -! 18 : The second dimension of the output array SIMPS does not match the -! number of interpolation points M. -! 19 : The first dimension of the output array WEIGHTS does not match the -! number of vertices for a a D-simplex (D+1). -! 20 : The second dimension of the output array WEIGHTS does not match the -! number of interpolation points M. -! 21 : The size of the error array IERR does not match the number of -! interpolation points M. -! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. -! 23 : The first dimension of INTERP_IN does not match the first -! dimension of INTERP_OUT. -! 24 : The second dimension of INTERP_IN does not match the number of -! data points PTS. -! 25 : The second dimension of INTERP_OUT does not match the number of -! interpolation points M. -! 26 : The budget supplied in IBUDGET does not contain a positive -! integer. -! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. -! 28 : The size of the RNORM output array does not match the number of -! interpolation points M. -! -! 30 : Two or more points in the data set PTS are too close together with -! respect to the working precision (EPS), which would result in a -! numerically degenerate simplex. -! 31 : All the data points in PTS lie in some lower dimensional linear -! manifold (up to the working precision), and no valid triangulation -! exists. -! 40 : An error caused DELAUNAYSPARSEP to terminate before this value could -! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may -! contain garbage values. -! -! 50 : A memory allocation error occurred while allocating the work array -! WORK. -! -! 60 : The budget was exceeded before the algorithm converged on this -! value. If the dimension is high, try increasing IBUDGET. This -! error can also be caused by a working precision EPS that is too -! small for the conditioning of the problem. -! -! 61 : A value that was judged appropriate later caused LAPACK to encounter a -! singularity. Try increasing the value of EPS. -! -! 70 : Allocation error for the extrapolation work arrays. -! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection -! of an extrapolation point onto the convex hull. -! 72 : The SLATEC subroutine DWNNLS has reported a usage error. -! -! The errors 72, 80--83 should never occur, and likely indicate a -! compiler bug or hardware failure. -! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. -! 81 : The LAPACK subroutine DGETRF has reported an illegal value. -! 82 : The LAPACK subroutine DGETRS has reported an illegal value. -! 83 : The LAPACK subroutine DORMQR has reported an illegal value. -! -! 90 : The value of PMODE is not valid. -! -! -! Optional arguments: -! -! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of -! the data points in PTS on input. The first dimension of INTERP_IN is -! inferred to be the dimension of these response vectors, and the -! second dimension must match N. If present, the response values will -! be computed for each interpolation point in Q, and stored in INTERP_OUT, -! which therefore must also be present. If both INTERP_IN and INTERP_OUT -! are omitted, only the containing simplices and convex combination -! weights are returned. -! -! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each -! interpolation point in Q on output. The first dimension of INTERP_OU -! must match the first dimension of INTERP_IN, and the second dimension -! must match M. If present, the response values at each interpolation -! point are computed as a convex combination of the response values -! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing -! that interpolation point. Therefore, if INTERP_OUT is present, then -! INTERP_IN must also be present. If both are omitted, only the -! simplices and convex combination weights are returned. -! -! EPS contains the real working precision for the problem on input. By -! default, EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff -! for the machine. In general, any values that differ by less than EPS -! are judged as equal, and any weights that are greater than -EPS are -! judged as nonnegative. EPS cannot take a value less than the default -! value of \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, -! the default value will be used instead automatically. -! -! EXTRAP contains the real maximum extrapolation distance (relative to the -! diameter of PTS) on input. Interpolation at a point outside the convex -! hull of PTS is done by projecting that point onto the convex hull, and -! then doing normal Delaunay interpolation at that projection. -! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) -! units outside the convex hull of PTS will not be done and an error code -! of 2 will be returned. Note that computing the projection can be -! expensive. Setting EXTRAP=0 will cause all extrapolation points to be -! ignored without ever computing a projection. By default, EXTRAP=0.1 -! (extrapolate by up to 10% of the diameter of PTS). -! -! RNORM(1:M) contains the real unscaled projection (2-norm) distances from -! any projection computations on output. If not present, these distances -! are still computed for each extrapolation point, but are never returned. -! -! IBUDGET on input contains the integer budget for performing flips while -! iterating toward the simplex containing each interpolation point in Q. -! This prevents DELAUNAYSPARSEP from falling into an infinite loop when -! an inappropriate value of EPS is given with respect to the problem -! conditioning. By default, IBUDGET=50000. However, for extremely -! high-dimensional problems and pathological inputs, the default value -! may be insufficient. -! -! CHAIN is a logical input argument that determines whether a new first -! simplex should be constructed for each interpolation point -! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." -! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not -! recommended, unless the size of the triangulation is relatively small -! or the interpolation points are known to be tightly clustered. -! -! EXACT is a logical input argument that determines whether the exact -! diameter should be computed and whether a check for duplicate data -! points should be performed in advance. When EXACT=.FALSE., the -! diameter of PTS is approximated by twice the distance from the -! barycenter of PTS to the farthest point in PTS, and no check is -! done to find the closest pair of points, which could result in hard -! to find bugs later on. When EXACT=.TRUE., the exact diameter is -! computed and an error is returned whenever PTS contains duplicate -! values up to the precision EPS. By default EXACT=.TRUE., but setting -! EXACT=.FALSE. could result in significant speedup when N is large. -! It is strongly recommended that most users leave EXACT=.TRUE., as -! setting EXACT=.FALSE. could result in input errors that are difficult -! to identify. Also, the diameter approximation could be wrong by up to -! a factor of two. -! -! PMODE is an integer specifying the level of parallelism to be exploited. -! If PMODE = 1, then parallelism is exploited at the level of the loop -! over all interpolation points (Level 1 parallelism). -! If PMODE = 2, then parallelism is exploited at the level of the loops -! over data points when constructing/flipping simplices (Level 2 -! parallelism). -! If PMODE = 3, then parallelism is exploited at both levels. Note: this -! implies that the total number of threads active at any time could be up -! to OMP_NUM_THREADS^2. -! By default, PMODE is set to 1 if there is more than 1 interpolation -! point and 2 otherwise. -! -! -! Subroutines and functions directly referenced from BLAS are -! DDOT, DGEMV, DNRM2, DTRSM, -! and from LAPACK are -! DGEQP3, DGETRF, DGETRS, DORMQR. -! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its -! SLATEC dependencies have been slightly edited to comply with the Fortran -! 2008 standard, with all print statements and references to stderr being -! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 -! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS -! Algorithm 777) is used for the real data type. The REAL_PRECISION module, -! DELAUNAYSPARSEP, and DWNNLS and its dependencies comply with the Fortran -! 2008 standard. -! -! Primary Author: Tyler H. Chang -! Last Update: March, 2020 -!''' - - # Setting up "d" - d = ctypes.c_int(d) - - # Setting up "n" - n = ctypes.c_int(n) - - # Setting up "m" - m = ctypes.c_int(m) - - # Setting up "pts" - pts_local = np.asarray(pts, dtype=ctypes.c_double) - pts_dim_1 = ctypes.c_int(pts_local.shape[0]) - pts_dim_2 = ctypes.c_int(pts_local.shape[1]) - - # Setting up "q" - q_local = np.asarray(q, dtype=ctypes.c_double) - q_dim_1 = ctypes.c_int(q_local.shape[0]) - q_dim_2 = ctypes.c_int(q_local.shape[1]) - - # Setting up "simps" - simps_local = np.asarray(simps, dtype=ctypes.c_int) - simps_dim_1 = ctypes.c_int(simps_local.shape[0]) - simps_dim_2 = ctypes.c_int(simps_local.shape[1]) - - # Setting up "weights" - weights_local = np.asarray(weights, dtype=ctypes.c_double) - weights_dim_1 = ctypes.c_int(weights_local.shape[0]) - weights_dim_2 = ctypes.c_int(weights_local.shape[1]) - - # Setting up "ierr" - ierr_local = np.asarray(ierr, dtype=ctypes.c_int) - # In accordance with how the Fortran code might be normally used, - # and mathematical notation, grabbing the last dimension allows - # ierr to be passed as a column vector instead of a flat vector. - ierr_dim_1 = ctypes.c_int(ierr_local.shape[-1]) - - # Setting up "interp_in" - interp_in_present = ctypes.c_bool(True) - interp_in_dim_1 = ctypes.c_int(0) - interp_in_dim_2 = ctypes.c_int(0) - if (interp_in is None): - interp_in_present = ctypes.c_bool(False) - interp_in = np.zeros(shape=(1,1), dtype=ctypes.c_double, order='F') - elif (type(interp_in) == bool) and (interp_in): - interp_in = np.zeros(shape=(1,1), dtype=ctypes.c_double, order='F') - interp_in_dim_1 = ctypes.c_int(interp_in.shape[0]) - interp_in_dim_2 = ctypes.c_int(interp_in.shape[1]) - elif (not np.asarray(interp_in).flags.f_contiguous): - raise(Exception("The numpy array given as argument 'interp_in' was not f_contiguous.")) - else: - interp_in_dim_1 = ctypes.c_int(interp_in.shape[0]) - interp_in_dim_2 = ctypes.c_int(interp_in.shape[1]) - interp_in_local = np.asarray(interp_in, dtype=ctypes.c_double) - - # Setting up "interp_out" - interp_out_present = ctypes.c_bool(True) - interp_out_dim_1 = ctypes.c_int(0) - interp_out_dim_2 = ctypes.c_int(0) - if (interp_out is None): - interp_out_present = ctypes.c_bool(False) - interp_out = np.zeros(shape=(1,1), dtype=ctypes.c_double, order='F') - elif (type(interp_out) == bool) and (interp_out): - interp_out = np.zeros(shape=(1,1), dtype=ctypes.c_double, order='F') - interp_out_dim_1 = ctypes.c_int(interp_out.shape[0]) - interp_out_dim_2 = ctypes.c_int(interp_out.shape[1]) - elif (not np.asarray(interp_out).flags.f_contiguous): - raise(Exception("The numpy array given as argument 'interp_out' was not f_contiguous.")) - else: - interp_out_dim_1 = ctypes.c_int(interp_out.shape[0]) - interp_out_dim_2 = ctypes.c_int(interp_out.shape[1]) - interp_out_local = np.asarray(interp_out, dtype=ctypes.c_double) - - # Setting up "eps" - eps_present = ctypes.c_bool(True) - if (eps is None): - eps_present = ctypes.c_bool(False) - eps = 1 - eps_local = ctypes.c_double(eps) - - # Setting up "extrap" - extrap_present = ctypes.c_bool(True) - if (extrap is None): - extrap_present = ctypes.c_bool(False) - extrap = 1 - extrap_local = ctypes.c_double(extrap) - - # Setting up "rnorm" - rnorm_present = ctypes.c_bool(True) - rnorm_dim_1 = ctypes.c_int(0) - if (rnorm is None): - rnorm_present = ctypes.c_bool(False) - rnorm = np.zeros(shape=(1), dtype=ctypes.c_double, order='F') - elif (type(rnorm) == bool) and (rnorm): - rnorm = np.zeros(shape=(1), dtype=ctypes.c_double, order='F') - # In accordance with how the Fortran code might be normally used, - # and mathematical notation, grabbing the last dimension allows - # rnorm to be passed as a column vector instead of a flat vector. - rnorm_dim_1 = rnorm.shape[-1] - elif (not np.asarray(rnorm).flags.f_contiguous): - raise(Exception("The numpy array given as argument 'rnorm' was not f_contiguous.")) - else: - # In accordance with how the Fortran code might be normally used, - # and mathematical notation, grabbing the last dimension allows - # rnorm to be passed as a column vector instead of a flat vector. - rnorm_dim_1 = ctypes.c_int(rnorm.shape[-1]) - rnorm_local = np.asarray(rnorm, dtype=ctypes.c_double) - - # Setting up "ibudget" - ibudget_present = ctypes.c_bool(True) - if (ibudget is None): - ibudget_present = ctypes.c_bool(False) - ibudget = 1 - ibudget_local = ctypes.c_int(ibudget) - - # Setting up "chain" - chain_present = ctypes.c_bool(True) - if (chain is None): - chain_present = ctypes.c_bool(False) - chain = 1 - chain_local = ctypes.c_bool(chain) - - # Setting up "exact" - exact_present = ctypes.c_bool(True) - if (exact is None): - exact_present = ctypes.c_bool(False) - exact = 1 - exact_local = ctypes.c_bool(exact) - - # Setting up "pmode" - pmode_present = ctypes.c_bool(True) - if (pmode is None): - pmode_present = ctypes.c_bool(False) - pmode = 1 - pmode_local = ctypes.c_int(pmode) - - # Call C-accessible Fortran wrapper. - delsparse_clib.c_delaunaysparsep(ctypes.byref(d), ctypes.byref(n), ctypes.byref(pts_dim_1), ctypes.byref(pts_dim_2), ctypes.c_void_p(pts_local.ctypes.data), ctypes.byref(m), ctypes.byref(q_dim_1), ctypes.byref(q_dim_2), ctypes.c_void_p(q_local.ctypes.data), ctypes.byref(simps_dim_1), ctypes.byref(simps_dim_2), ctypes.c_void_p(simps_local.ctypes.data), ctypes.byref(weights_dim_1), ctypes.byref(weights_dim_2), ctypes.c_void_p(weights_local.ctypes.data), ctypes.byref(ierr_dim_1), ctypes.c_void_p(ierr_local.ctypes.data), ctypes.byref(interp_in_present), ctypes.byref(interp_in_dim_1), ctypes.byref(interp_in_dim_2), ctypes.c_void_p(interp_in_local.ctypes.data), ctypes.byref(interp_out_present), ctypes.byref(interp_out_dim_1), ctypes.byref(interp_out_dim_2), ctypes.c_void_p(interp_out_local.ctypes.data), ctypes.byref(eps_present), ctypes.byref(eps_local), ctypes.byref(extrap_present), ctypes.byref(extrap_local), ctypes.byref(rnorm_present), ctypes.byref(rnorm_dim_1), ctypes.c_void_p(rnorm_local.ctypes.data), ctypes.byref(ibudget_present), ctypes.byref(ibudget_local), ctypes.byref(chain_present), ctypes.byref(chain_local), ctypes.byref(exact_present), ctypes.byref(exact_local), ctypes.byref(pmode_present), ctypes.byref(pmode_local)) - - # Return final results, 'INTENT(OUT)' arguments only. - return np.asarray(pts_local), np.asarray(q_local), np.asarray(simps_local), np.asarray(weights_local), np.asarray(ierr_local), (np.asarray(interp_out_local) if interp_out_present else None), (np.asarray(rnorm_local) if rnorm_present else None) - diff --git a/extras/delsparsepy/delsparse_src/blas.f b/extras/delsparsepy/delsparse_src/blas.f deleted file mode 100755 index df991ff..0000000 --- a/extras/delsparsepy/delsparse_src/blas.f +++ /dev/null @@ -1,2206 +0,0 @@ - -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* ====================================== - - DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* Purpose: -* ============= -* -* DASUM takes the sum of the absolute values. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 3/93 to return if incx .le. 0. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,M,MP1,NINCX -* .. -* .. Intrinsic Functions .. - INTRINSIC DABS,MOD -* .. - DASUM = 0.0D0 - DTEMP = 0.0D0 - IF (N.LE.0 .OR. INCX.LE.0) RETURN - IF (INCX.EQ.1) THEN -* code for increment equal to 1 -* -* -* clean-up loop -* - M = MOD(N,6) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DTEMP + DABS(DX(I)) - END DO - IF (N.LT.6) THEN - DASUM = DTEMP - RETURN - END IF - END IF - MP1 = M + 1 - DO I = MP1,N,6 - DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) + - $ DABS(DX(I+2)) + DABS(DX(I+3)) + - $ DABS(DX(I+4)) + DABS(DX(I+5)) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - DTEMP = DTEMP + DABS(DX(I)) - END DO - END IF - DASUM = DTEMP - RETURN - END - - SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - DOUBLE PRECISION DA - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* Purpose: -* ============= -* -* DAXPY constant times a vector plus a vector. -* uses unrolled loops for increments equal to one. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DA is DOUBLE PRECISION. On entry, DA specifies the scalar alpha. -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -* -* INCY is INTEGER storage spacing between elements of DY -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (DA.EQ.0.0D0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,4) - IF (M.NE.0) THEN - DO I = 1,M - DY(I) = DY(I) + DA*DX(I) - END DO - END IF - IF (N.LT.4) RETURN - MP1 = M + 1 - DO I = MP1,N,4 - DY(I) = DY(I) + DA*DX(I) - DY(I+1) = DY(I+1) + DA*DX(I+1) - DY(I+2) = DY(I+2) + DA*DX(I+2) - DY(I+3) = DY(I+3) + DA*DX(I+3) - END DO - ELSE -* -* code for unequal increments or equal increments -* 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 I = 1,N - DY(IY) = DY(IY) + DA*DX(IX) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN - END - - SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* Purpose: -* ============= -* -* DCOPY copies a vector, x, to a vector, y. -* uses unrolled loops for increments equal to 1. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -* -* INCY is INTEGER storage spacing between elements of DY -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,7) - IF (M.NE.0) THEN - DO I = 1,M - DY(I) = DX(I) - END DO - IF (N.LT.7) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,7 - DY(I) = DX(I) - DY(I+1) = DX(I+1) - DY(I+2) = DX(I+2) - DY(I+3) = DX(I+3) - DY(I+4) = DX(I+4) - DY(I+5) = DX(I+5) - DY(I+6) = DX(I+6) - END DO - ELSE -* -* code for unequal increments or equal increments -* 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 I = 1,N - DY(IY) = DX(IX) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN - END - - DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* Purpose: -* ============= -* -* DDOT forms the dot product of two vectors. -* uses unrolled loops for increments equal to one. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -* -* INCY is INTEGER storage spacing between elements of DY -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - DDOT = 0.0D0 - DTEMP = 0.0D0 - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,5) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DTEMP + DX(I)*DY(I) - END DO - IF (N.LT.5) THEN - DDOT=DTEMP - RETURN - END IF - END IF - MP1 = M + 1 - DO I = MP1,N,5 - DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) + - $ DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) - END DO - ELSE -* -* code for unequal increments or equal increments -* 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 I = 1,N - DTEMP = DTEMP + DX(IX)*DY(IY) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - DDOT = DTEMP - RETURN - END - - SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* -- Reference BLAS level3 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of -* Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER K,LDA,LDB,LDC,M,N - CHARACTER TRANSA,TRANSB -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB - LOGICAL NOTA,NOTB -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Set NOTA and NOTB as true if A and B respectively are -* not -* transposed and set NROWA, NCOLA and NROWB as the number of -* rows -* and columns of A and the number of rows of B -* respectively. -* - NOTA = LSAME(TRANSA,'N') - NOTB = LSAME(TRANSB,'N') - IF (NOTA) THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - END IF - IF (NOTB) THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. - + (.NOT.LSAME(TRANSA,'T'))) THEN - INFO = 1 - ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. - + (.NOT.LSAME(TRANSB,'T'))) THEN - INFO = 2 - ELSE IF (M.LT.0) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (K.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 8 - ELSE IF (LDB.LT.MAX(1,NROWB)) THEN - INFO = 10 - ELSE IF (LDC.LT.MAX(1,M)) THEN - INFO = 13 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGEMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN -* -* And if alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,M - C(I,J) = BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF (NOTB) THEN - IF (NOTA) THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 50 I = 1,M - C(I,J) = ZERO - 50 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 60 I = 1,M - C(I,J) = BETA*C(I,J) - 60 CONTINUE - END IF - DO 80 L = 1,K - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - ELSE -* -* Form C := alpha*A**T*B + beta*C -* - DO 120 J = 1,N - DO 110 I = 1,M - TEMP = ZERO - DO 100 L = 1,K - TEMP = TEMP + A(L,I)*B(L,J) - 100 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 110 CONTINUE - 120 CONTINUE - END IF - ELSE - IF (NOTA) THEN -* -* Form C := alpha*A*B**T + beta*C -* - DO 170 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 130 I = 1,M - C(I,J) = ZERO - 130 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 140 I = 1,M - C(I,J) = BETA*C(I,J) - 140 CONTINUE - END IF - DO 160 L = 1,K - TEMP = ALPHA*B(J,L) - DO 150 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - ELSE -* -* Form C := alpha*A**T*B**T + beta*C -* - DO 200 J = 1,N - DO 190 I = 1,M - TEMP = ZERO - DO 180 L = 1,K - TEMP = TEMP + A(L,I)*B(J,L) - 180 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 190 CONTINUE - 200 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMM . -* - END - - SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* -- Reference BLAS level2 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER INCX,INCY,LDA,M,N - CHARACTER TRANS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* Purpose: -* ============= -* -* DGEMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n matrix. -* -* Arguments: -* ========== -* -* TRANS is CHARACTER*1 -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. -* M is INTEGER -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* -* N is INTEGER -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* -* ALPHA is DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* -* A is DOUBLE PRECISION array, dimension ( LDA, N ) -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. -* -* LDA is INTEGER -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* -* X is DOUBLE PRECISION array, dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* -* INCX is INTEGER -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* -* BETA is DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* -* Y is DOUBLE PRECISION array, dimension at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry with BETA non-zero, the incremented array Y -* must contain the vector y. On exit, Y is overwritten by the -* updated vector y. -* -* INCY is INTEGER -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* -* Further Details: -* ===================== -* -* Level 2 Blas routine. -* The vector and matrix arguments are not referenced when N = 0, or M = 0 -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 1 - ELSE IF (M.LT.0) THEN - INFO = 2 - ELSE IF (N.LT.0) THEN - INFO = 3 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - ELSE IF (INCY.EQ.0) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGEMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF (LSAME(TRANS,'N')) THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (LENX-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (LENY-1)*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF (BETA.NE.ONE) THEN - IF (INCY.EQ.1) THEN - IF (BETA.EQ.ZERO) THEN - DO 10 I = 1,LENY - Y(I) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1,LENY - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ELSE - IY = KY - IF (BETA.EQ.ZERO) THEN - DO 30 I = 1,LENY - Y(IY) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1,LENY - Y(IY) = BETA*Y(IY) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF (ALPHA.EQ.ZERO) RETURN - IF (LSAME(TRANS,'N')) THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF (INCY.EQ.1) THEN - DO 60 J = 1,N - TEMP = ALPHA*X(JX) - DO 50 I = 1,M - Y(I) = Y(I) + TEMP*A(I,J) - 50 CONTINUE - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80 J = 1,N - TEMP = ALPHA*X(JX) - IY = KY - DO 70 I = 1,M - Y(IY) = Y(IY) + TEMP*A(I,J) - IY = IY + INCY - 70 CONTINUE - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A**T*x + y. -* - JY = KY - IF (INCX.EQ.1) THEN - DO 100 J = 1,N - TEMP = ZERO - DO 90 I = 1,M - TEMP = TEMP + A(I,J)*X(I) - 90 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120 J = 1,N - TEMP = ZERO - IX = KX - DO 110 I = 1,M - TEMP = TEMP + A(I,J)*X(IX) - IX = IX + INCX - 110 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMV . -* - END - - SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* -- Reference BLAS level2 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of -* Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX,INCY,LDA,M,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER(ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,J,JY,KX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (M.LT.0) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (INCX.EQ.0) THEN - INFO = 5 - ELSE IF (INCY.EQ.0) THEN - INFO = 7 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGER ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (INCY.GT.0) THEN - JY = 1 - ELSE - JY = 1 - (N-1)*INCY - END IF - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*Y(JY) - DO 10 I = 1,M - A(I,J) = A(I,J) + X(I)*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (M-1)*INCX - END IF - DO 40 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*Y(JY) - IX = KX - DO 30 I = 1,M - A(I,J) = A(I,J) + X(IX)*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of DGER . -* - END - - DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION X(*) -* .. -* -* Purpose: -* ============= -* -* DNRM2 returns the euclidean norm of a vector via the function -* name, so that -* -* DNRM2 := sqrt( x'*x ) -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* Further Details: -* ===================== -* -* -- This version written on 25-October-1982. -* Modified on 14-October-1993 to inline the call to DLASSQ. -* Sven Hammarling, Nag Ltd. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ - INTEGER IX -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS,SQRT -* .. - IF (N.LT.1 .OR. INCX.LT.1) THEN - NORM = ZERO - ELSE IF (N.EQ.1) THEN - NORM = ABS(X(1)) - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10 IX = 1,1 + (N-1)*INCX,INCX - IF (X(IX).NE.ZERO) THEN - ABSXI = ABS(X(IX)) - IF (SCALE.LT.ABSXI) THEN - SSQ = ONE + SSQ* (SCALE/ABSXI)**2 - SCALE = ABSXI - ELSE - SSQ = SSQ + (ABSXI/SCALE)**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE*SQRT(SSQ) - END IF -* - DNRM2 = NORM - RETURN -* -* End of DNRM2. -* - END - - SUBROUTINE DSCAL(N,DA,DX,INCX) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - DOUBLE PRECISION DA - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* Purpose: -* ============= -* -* DSCAL scales a vector by a constant. -* uses unrolled loops for increment equal to 1. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DA is DOUBLE PRECISION On entry, DA specifies the scalar alpha. -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 3/93 to return if incx .le. 0. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,M,MP1,NINCX -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0 .OR. INCX.LE.0) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* -* -* clean-up loop -* - M = MOD(N,5) - IF (M.NE.0) THEN - DO I = 1,M - DX(I) = DA*DX(I) - END DO - IF (N.LT.5) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,5 - DX(I) = DA*DX(I) - DX(I+1) = DA*DX(I+1) - DX(I+2) = DA*DX(I+2) - DX(I+3) = DA*DX(I+3) - DX(I+4) = DA*DX(I+4) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - DX(I) = DA*DX(I) - END DO - END IF - RETURN - END - - SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* Purpose: -* ============= -* -* DSWAP interchanges two vectors. -* uses unrolled loops for increments equal to 1. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -* -* INCY is INTEGER storage spacing between elements of DY -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,3) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - END DO - IF (N.LT.3) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,3 - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - DTEMP = DX(I+1) - DX(I+1) = DY(I+1) - DY(I+1) = DTEMP - DTEMP = DX(I+2) - DX(I+2) = DY(I+2) - DY(I+2) = DTEMP - END DO - ELSE -* -* code for unequal increments or equal increments 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 I = 1,N - DTEMP = DX(IX) - DX(IX) = DY(IY) - DY(IY) = DTEMP - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN - END - - SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* -- Reference BLAS level3 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of -* Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER LDA,LDB,M,N - CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,K,NROWA - LOGICAL LSIDE,NOUNIT,UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Test the input parameters. -* - LSIDE = LSAME(SIDE,'L') - IF (LSIDE) THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME(DIAG,'N') - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN - INFO = 1 - ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 2 - ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. - + (.NOT.LSAME(TRANSA,'T')) .AND. - + (.NOT.LSAME(TRANSA,'C'))) THEN - INFO = 3 - ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN - INFO = 4 - ELSE IF (M.LT.0) THEN - INFO = 5 - ELSE IF (N.LT.0) THEN - INFO = 6 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDB.LT.MAX(1,M)) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (M.EQ.0 .OR. N.EQ.0) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - B(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF (LSIDE) THEN - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*A*B. -* - IF (UPPER) THEN - DO 50 J = 1,N - DO 40 K = 1,M - IF (B(K,J).NE.ZERO) THEN - TEMP = ALPHA*B(K,J) - DO 30 I = 1,K - 1 - B(I,J) = B(I,J) + TEMP*A(I,K) - 30 CONTINUE - IF (NOUNIT) TEMP = TEMP*A(K,K) - B(K,J) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80 J = 1,N - DO 70 K = M,1,-1 - IF (B(K,J).NE.ZERO) THEN - TEMP = ALPHA*B(K,J) - B(K,J) = TEMP - IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) - DO 60 I = K + 1,M - B(I,J) = B(I,J) + TEMP*A(I,K) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A**T*B. -* - IF (UPPER) THEN - DO 110 J = 1,N - DO 100 I = M,1,-1 - TEMP = B(I,J) - IF (NOUNIT) TEMP = TEMP*A(I,I) - DO 90 K = 1,I - 1 - TEMP = TEMP + A(K,I)*B(K,J) - 90 CONTINUE - B(I,J) = ALPHA*TEMP - 100 CONTINUE - 110 CONTINUE - ELSE - DO 140 J = 1,N - DO 130 I = 1,M - TEMP = B(I,J) - IF (NOUNIT) TEMP = TEMP*A(I,I) - DO 120 K = I + 1,M - TEMP = TEMP + A(K,I)*B(K,J) - 120 CONTINUE - B(I,J) = ALPHA*TEMP - 130 CONTINUE - 140 CONTINUE - END IF - END IF - ELSE - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*B*A. -* - IF (UPPER) THEN - DO 180 J = N,1,-1 - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 150 I = 1,M - B(I,J) = TEMP*B(I,J) - 150 CONTINUE - DO 170 K = 1,J - 1 - IF (A(K,J).NE.ZERO) THEN - TEMP = ALPHA*A(K,J) - DO 160 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - ELSE - DO 220 J = 1,N - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 190 I = 1,M - B(I,J) = TEMP*B(I,J) - 190 CONTINUE - DO 210 K = J + 1,N - IF (A(K,J).NE.ZERO) THEN - TEMP = ALPHA*A(K,J) - DO 200 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 200 CONTINUE - END IF - 210 CONTINUE - 220 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A**T. -* - IF (UPPER) THEN - DO 260 K = 1,N - DO 240 J = 1,K - 1 - IF (A(J,K).NE.ZERO) THEN - TEMP = ALPHA*A(J,K) - DO 230 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 230 CONTINUE - END IF - 240 CONTINUE - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(K,K) - IF (TEMP.NE.ONE) THEN - DO 250 I = 1,M - B(I,K) = TEMP*B(I,K) - 250 CONTINUE - END IF - 260 CONTINUE - ELSE - DO 300 K = N,1,-1 - DO 280 J = K + 1,N - IF (A(J,K).NE.ZERO) THEN - TEMP = ALPHA*A(J,K) - DO 270 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 270 CONTINUE - END IF - 280 CONTINUE - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(K,K) - IF (TEMP.NE.ONE) THEN - DO 290 I = 1,M - B(I,K) = TEMP*B(I,K) - 290 CONTINUE - END IF - 300 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMM . -* - END - - SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* -- Reference BLAS level2 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of -* Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER INCX,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER(ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,J,JX,KX - LOGICAL NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := A*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - DO 10 I = 1,J - 1 - X(I) = X(I) + TEMP*A(I,J) - 10 CONTINUE - IF (NOUNIT) X(J) = X(J)*A(J,J) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 30 I = 1,J - 1 - X(IX) = X(IX) + TEMP*A(I,J) - IX = IX + INCX - 30 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*A(J,J) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - DO 50 I = N,J + 1,-1 - X(I) = X(I) + TEMP*A(I,J) - 50 CONTINUE - IF (NOUNIT) X(J) = X(J)*A(J,J) - END IF - 60 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 80 J = N,1,-1 - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 70 I = N,J + 1,-1 - X(IX) = X(IX) + TEMP*A(I,J) - IX = IX - INCX - 70 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*A(J,J) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A**T*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 100 J = N,1,-1 - TEMP = X(J) - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 90 I = J - 1,1,-1 - TEMP = TEMP + A(I,J)*X(I) - 90 CONTINUE - X(J) = TEMP - 100 CONTINUE - ELSE - JX = KX + (N-1)*INCX - DO 120 J = N,1,-1 - TEMP = X(JX) - IX = JX - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 110 I = J - 1,1,-1 - IX = IX - INCX - TEMP = TEMP + A(I,J)*X(IX) - 110 CONTINUE - X(JX) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 140 J = 1,N - TEMP = X(J) - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 130 I = J + 1,N - TEMP = TEMP + A(I,J)*X(I) - 130 CONTINUE - X(J) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160 J = 1,N - TEMP = X(JX) - IX = JX - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 150 I = J + 1,N - IX = IX + INCX - TEMP = TEMP + A(I,J)*X(IX) - 150 CONTINUE - X(JX) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMV . -* - END - - SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* -- Reference BLAS level3 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER LDA,LDB,M,N - CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*) -* .. -* -* Purpose: -* ============= -* -* DTRSM solves one of the matrix equations -* -* op( A )*X = alpha*B, or X*op( A ) = alpha*B, -* -* where alpha is a scalar, X and B are m by n matrices, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A**T. -* -* The matrix X is overwritten on B. -* -* Arguments: -* ========== -* -* SIDE is CHARACTER*1 -* On entry, SIDE specifies whether op( A ) appears on the left -* or right of X as follows: -* -* SIDE = 'L' or 'l' op( A )*X = alpha*B. -* -* SIDE = 'R' or 'r' X*op( A ) = alpha*B. -* -* UPLO is CHARACTER*1 -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* TRANSA is CHARACTER*1 -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n' op( A ) = A. -* -* TRANSA = 'T' or 't' op( A ) = A**T. -* -* TRANSA = 'C' or 'c' op( A ) = A**T. -* -* DIAG is CHARACTER*1 -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* M is INTEGER -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* -* N is INTEGER -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* -* ALPHA is DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* -* A is DOUBLE PRECISION array, dimension ( LDA, k ), -* where k is m when SIDE = 'L' or 'l' -* and k is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* -* LDA is INTEGER -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* -* B is DOUBLE PRECISION array, dimension ( LDB, N ) -* Before entry, the leading m by n part of the array B must -* contain the right-hand side matrix B, and on exit is -* overwritten by the solution matrix X. -* -* LDB is INTEGER -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* -* Further Details: -* ===================== -* -* Level 3 Blas routine. -* -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,K,NROWA - LOGICAL LSIDE,NOUNIT,UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Test the input parameters. -* - LSIDE = LSAME(SIDE,'L') - IF (LSIDE) THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME(DIAG,'N') - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN - INFO = 1 - ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 2 - ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. - + (.NOT.LSAME(TRANSA,'T')) .AND. - + (.NOT.LSAME(TRANSA,'C'))) THEN - INFO = 3 - ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN - INFO = 4 - ELSE IF (M.LT.0) THEN - INFO = 5 - ELSE IF (N.LT.0) THEN - INFO = 6 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDB.LT.MAX(1,M)) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRSM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (M.EQ.0 .OR. N.EQ.0) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - B(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF (LSIDE) THEN - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*inv( A )*B. -* - IF (UPPER) THEN - DO 60 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 30 I = 1,M - B(I,J) = ALPHA*B(I,J) - 30 CONTINUE - END IF - DO 50 K = M,1,-1 - IF (B(K,J).NE.ZERO) THEN - IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) - DO 40 I = 1,K - 1 - B(I,J) = B(I,J) - B(K,J)*A(I,K) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 70 I = 1,M - B(I,J) = ALPHA*B(I,J) - 70 CONTINUE - END IF - DO 90 K = 1,M - IF (B(K,J).NE.ZERO) THEN - IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) - DO 80 I = K + 1,M - B(I,J) = B(I,J) - B(K,J)*A(I,K) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A**T )*B. -* - IF (UPPER) THEN - DO 130 J = 1,N - DO 120 I = 1,M - TEMP = ALPHA*B(I,J) - DO 110 K = 1,I - 1 - TEMP = TEMP - A(K,I)*B(K,J) - 110 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(I,I) - B(I,J) = TEMP - 120 CONTINUE - 130 CONTINUE - ELSE - DO 160 J = 1,N - DO 150 I = M,1,-1 - TEMP = ALPHA*B(I,J) - DO 140 K = I + 1,M - TEMP = TEMP - A(K,I)*B(K,J) - 140 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(I,I) - B(I,J) = TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*B*inv( A ). -* - IF (UPPER) THEN - DO 210 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 170 I = 1,M - B(I,J) = ALPHA*B(I,J) - 170 CONTINUE - END IF - DO 190 K = 1,J - 1 - IF (A(K,J).NE.ZERO) THEN - DO 180 I = 1,M - B(I,J) = B(I,J) - A(K,J)*B(I,K) - 180 CONTINUE - END IF - 190 CONTINUE - IF (NOUNIT) THEN - TEMP = ONE/A(J,J) - DO 200 I = 1,M - B(I,J) = TEMP*B(I,J) - 200 CONTINUE - END IF - 210 CONTINUE - ELSE - DO 260 J = N,1,-1 - IF (ALPHA.NE.ONE) THEN - DO 220 I = 1,M - B(I,J) = ALPHA*B(I,J) - 220 CONTINUE - END IF - DO 240 K = J + 1,N - IF (A(K,J).NE.ZERO) THEN - DO 230 I = 1,M - B(I,J) = B(I,J) - A(K,J)*B(I,K) - 230 CONTINUE - END IF - 240 CONTINUE - IF (NOUNIT) THEN - TEMP = ONE/A(J,J) - DO 250 I = 1,M - B(I,J) = TEMP*B(I,J) - 250 CONTINUE - END IF - 260 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A**T ). -* - IF (UPPER) THEN - DO 310 K = N,1,-1 - IF (NOUNIT) THEN - TEMP = ONE/A(K,K) - DO 270 I = 1,M - B(I,K) = TEMP*B(I,K) - 270 CONTINUE - END IF - DO 290 J = 1,K - 1 - IF (A(J,K).NE.ZERO) THEN - TEMP = A(J,K) - DO 280 I = 1,M - B(I,J) = B(I,J) - TEMP*B(I,K) - 280 CONTINUE - END IF - 290 CONTINUE - IF (ALPHA.NE.ONE) THEN - DO 300 I = 1,M - B(I,K) = ALPHA*B(I,K) - 300 CONTINUE - END IF - 310 CONTINUE - ELSE - DO 360 K = 1,N - IF (NOUNIT) THEN - TEMP = ONE/A(K,K) - DO 320 I = 1,M - B(I,K) = TEMP*B(I,K) - 320 CONTINUE - END IF - DO 340 J = K + 1,N - IF (A(J,K).NE.ZERO) THEN - TEMP = A(J,K) - DO 330 I = 1,M - B(I,J) = B(I,J) - TEMP*B(I,K) - 330 CONTINUE - END IF - 340 CONTINUE - IF (ALPHA.NE.ONE) THEN - DO 350 I = 1,M - B(I,K) = ALPHA*B(I,K) - 350 CONTINUE - END IF - 360 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSM . -* - END - - INTEGER FUNCTION IDAMAX(N,DX,INCX) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* Purpose: -* ============= -* -* IDAMAX finds the index of the first element having maximum absolute value. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of SX -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 3/93 to return if incx .le. 0. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DMAX - INTEGER I,IX -* .. -* .. Intrinsic Functions .. - INTRINSIC DABS -* .. - IDAMAX = 0 - IF (N.LT.1 .OR. INCX.LE.0) RETURN - IDAMAX = 1 - IF (N.EQ.1) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* - DMAX = DABS(DX(1)) - DO I = 2,N - IF (DABS(DX(I)).GT.DMAX) THEN - IDAMAX = I - DMAX = DABS(DX(I)) - END IF - END DO - ELSE -* -* code for increment not equal to 1 -* - IX = 1 - DMAX = DABS(DX(1)) - IX = IX + INCX - DO I = 2,N - IF (DABS(DX(IX)).GT.DMAX) THEN - IDAMAX = I - DMAX = DABS(DX(IX)) - END IF - IX = IX + INCX - END DO - END IF - RETURN - END - - LOGICAL FUNCTION LSAME(CA,CB) -* -* -- Reference BLAS level1 routine (version 3.1) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - CHARACTER CA,CB -* .. -* -* Purpose: -* ============= -* -* LSAME returns .TRUE. if CA is the same letter as CB regardless of -* case. -* -* Arguments: -* ========== -* -* CA is CHARACTER*1 -* CB is CHARACTER*1 -* CA and CB specify the single characters to be compared. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ICHAR -* .. -* .. Local Scalars .. - INTEGER INTA,INTB,ZCODE -* .. -* -* Test if the characters are equal -* - LSAME = CA .EQ. CB - IF (LSAME) RETURN -* -* Now test for equivalence if both characters are alphabetic. -* - ZCODE = ICHAR('Z') -* -* Use 'Z' rather than 'A' so that ASCII can be detected on Prime -* machines, on which ICHAR returns a value with bit 8 set. -* ICHAR('A') on Prime machines returns 193 which is the same as -* ICHAR('A') on an EBCDIC machine. -* - INTA = ICHAR(CA) - INTB = ICHAR(CB) -* - IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN -* -* ASCII is assumed - ZCODE is the ASCII code of either lower or -* upper case 'Z'. -* - IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 - IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 -* - ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN -* -* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or -* upper case 'Z'. -* - IF (INTA.GE.129 .AND. INTA.LE.137 .OR. - + INTA.GE.145 .AND. INTA.LE.153 .OR. - + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 - IF (INTB.GE.129 .AND. INTB.LE.137 .OR. - + INTB.GE.145 .AND. INTB.LE.153 .OR. - + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 -* - ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN -* -* ASCII is assumed, on Prime machines - ZCODE is the ASCII code -* plus 128 of either lower or upper case 'Z'. -* - IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 - IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 - END IF - LSAME = INTA .EQ. INTB -* -* RETURN -* -* End of LSAME -* - END - - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* -- Reference BLAS level1 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - CHARACTER*(*) SRNAME - INTEGER INFO -* .. -* -* Purpose: -* ============= -* -* XERBLA is an error handler for the LAPACK routines. -* It is called by an LAPACK routine if an input parameter has an -* invalid value. A message is printed and execution stops. -* -* Installers may consider modifying the STOP statement in order to -* call system-specific exception-handling facilities. -* -* Arguments: -* ========== -* -* SRNAME is CHARACTER*(*) -* The name of the routine which called XERBLA. -* -* INFO is INTEGER -* The position of the invalid parameter in the parameter list -* of the calling routine. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC LEN_TRIM -* .. -* .. Executable Statements .. -* - WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO -* - STOP -* - 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', - $ 'an illegal value' ) -* -* End of XERBLA -* - END - diff --git a/extras/delsparsepy/delsparse_src/delsparse.f90 b/extras/delsparsepy/delsparse_src/delsparse.f90 deleted file mode 100644 index 3ba0a87..0000000 --- a/extras/delsparsepy/delsparse_src/delsparse.f90 +++ /dev/null @@ -1,2774 +0,0 @@ -MODULE DELSPARSE_MOD -! This module contains the REAL_PRECISION R8 data type for 64-bit arithmetic -! and interface blocks for the DELAUNAYSPARSES and DELAUNAYSPARSEP -! subroutines for computing the Delaunay simplices containing interpolation -! points Q in R^D given data points PTS. -USE REAL_PRECISION -PUBLIC - -INTERFACE - ! Interface for serial subroutine DELAUNAYSPARSES. - SUBROUTINE DELAUNAYSPARSES( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, & - IBUDGET, CHAIN, EXACT ) - USE REAL_PRECISION, ONLY : R8 - INTEGER, INTENT(IN) :: D, N - REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) - INTEGER, INTENT(IN) :: M - REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) - INTEGER, INTENT(OUT) :: SIMPS(:,:) - REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) - INTEGER, INTENT(OUT) :: IERR(:) - REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) - REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) - INTEGER, INTENT(IN), OPTIONAL :: IBUDGET - LOGICAL, INTENT(IN), OPTIONAL :: CHAIN - LOGICAL, INTENT(IN), OPTIONAL :: EXACT - END SUBROUTINE DELAUNAYSPARSES - - ! Interface for parallel subroutine DELAUNAYSPARSEP. - SUBROUTINE DELAUNAYSPARSEP( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, & - IBUDGET, CHAIN, EXACT, PMODE ) - USE REAL_PRECISION, ONLY : R8 - INTEGER, INTENT(IN) :: D, N - REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) - INTEGER, INTENT(IN) :: M - REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) - INTEGER, INTENT(OUT) :: SIMPS(:,:) - REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) - INTEGER, INTENT(OUT) :: IERR(:) - REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) - REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) - INTEGER, INTENT(IN), OPTIONAL :: IBUDGET - LOGICAL, INTENT(IN), OPTIONAL :: CHAIN - LOGICAL, INTENT(IN), OPTIONAL :: EXACT - INTEGER, INTENT(IN), OPTIONAL :: PMODE - END SUBROUTINE DELAUNAYSPARSEP - - ! Interface for SLATEC subroutine DWNNLS. - SUBROUTINE DWNNLS( W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, & - MODE, IWORK, WORK ) - USE REAL_PRECISION, ONLY : R8 - INTEGER :: IWORK(*), L, MA, MDW, ME, MODE, N - REAL(KIND=R8) :: PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) - END SUBROUTINE DWNNLS - -END INTERFACE - -END MODULE DELSPARSE_MOD - -SUBROUTINE DELAUNAYSPARSES( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EXACT ) -! This is a serial implementation of an algorithm for efficiently performing -! interpolation in R^D via the Delaunay triangulation. The algorithm is fully -! described and analyzed in -! -! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. -! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate -! interpolation in arbitrary dimension via the Delaunay triangulation. In -! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, -! USA. Article 12, 8 pages. -! -! -! On input: -! -! D is the dimension of the space for PTS and Q. -! -! N is the number of data points in PTS. -! -! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the -! coordinates of a single data point in R^D. -! -! M is the number of interpolation points in Q. -! -! Q(1:D,1:M) is a real valued matrix with M columns, each containing the -! coordinates of a single interpolation point in R^D. -! -! -! On output: -! -! PTS and Q have been rescaled and shifted. All the data points in PTS -! are now contained in the unit hyperball in R^D, and the points in Q -! have been shifted and scaled accordingly in relation to PTS. -! -! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns -! in PTS) for the D+1 vertices of the Delaunay simplex containing each -! interpolation point in Q. -! -! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each -! point in Q as a convex combination of the D+1 corresponding vertices -! in SIMPS. -! -! IERR(1:M) contains integer valued error flags associated with the -! computation of each of the M interpolation points in Q. The error -! codes are: -! -! 00 : Succesful interpolation. -! 01 : Succesful extrapolation (up to the allowed extrapolation distance). -! 02 : This point was outside the allowed extrapolation distance; the -! corresponding entries in SIMPS and WEIGHTS contain zero values. -! -! 10 : The dimension D must be positive. -! 11 : Too few data points to construct a triangulation (i.e., N < D+1). -! 12 : No interpolation points given (i.e., M < 1). -! 13 : The first dimension of PTS does not agree with the dimension D. -! 14 : The second dimension of PTS does not agree with the number of points N. -! 15 : The first dimension of Q does not agree with the dimension D. -! 16 : The second dimension of Q does not agree with the number of -! interpolation points M. -! 17 : The first dimension of the output array SIMPS does not match the number -! of vertices needed for a D-simplex (D+1). -! 18 : The second dimension of the output array SIMPS does not match the -! number of interpolation points M. -! 19 : The first dimension of the output array WEIGHTS does not match the -! number of vertices for a a D-simplex (D+1). -! 20 : The second dimension of the output array WEIGHTS does not match the -! number of interpolation points M. -! 21 : The size of the error array IERR does not match the number of -! interpolation points M. -! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. -! 23 : The first dimension of INTERP_IN does not match the first -! dimension of INTERP_OUT. -! 24 : The second dimension of INTERP_IN does not match the number of -! data points PTS. -! 25 : The second dimension of INTERP_OUT does not match the number of -! interpolation points M. -! 26 : The budget supplied in IBUDGET does not contain a positive -! integer. -! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. -! 28 : The size of the RNORM output array does not match the number of -! interpolation points M. -! -! 30 : Two or more points in the data set PTS are too close together with -! respect to the working precision (EPS), which would result in a -! numerically degenerate simplex. -! 31 : All the data points in PTS lie in some lower dimensional linear -! manifold (up to the working precision), and no valid triangulation -! exists. -! 40 : An error caused DELAUNAYSPARSES to terminate before this value could -! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may -! contain garbage values. -! -! 50 : A memory allocation error occurred while allocating the work array -! WORK. -! -! 60 : The budget was exceeded before the algorithm converged on this -! value. If the dimension is high, try increasing IBUDGET. This -! error can also be caused by a working precision EPS that is too -! small for the conditioning of the problem. -! -! 61 : A value that was judged appropriate later caused LAPACK to encounter a -! singularity. Try increasing the value of EPS. -! -! 70 : Allocation error for the extrapolation work arrays. -! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection -! of an extrapolation point onto the convex hull. -! 72 : The SLATEC subroutine DWNNLS has reported a usage error. -! -! The errors 72, 80--83 should never occur, and likely indicate a -! compiler bug or hardware failure. -! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. -! 81 : The LAPACK subroutine DGETRF has reported an illegal value. -! 82 : The LAPACK subroutine DGETRS has reported an illegal value. -! 83 : The LAPACK subroutine DORMQR has reported an illegal value. -! -! -! Optional arguments: -! -! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of -! the data points in PTS on input. The first dimension of INTERP_IN is -! inferred to be the dimension of these response vectors, and the -! second dimension must match N. If present, the response values will -! be computed for each interpolation point in Q, and stored in INTERP_OUT, -! which therefore must also be present. If both INTERP_IN and INTERP_OUT -! are omitted, only the containing simplices and convex combination -! weights are returned. -! -! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each -! interpolation point in Q on output. The first dimension of INTERP_OUT -! must match the first dimension of INTERP_IN, and the second dimension -! must match M. If present, the response values at each interpolation -! point are computed as a convex combination of the response values -! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing -! that interpolation point. Therefore, if INTERP_OUT is present, then -! INTERP_IN must also be present. If both are omitted, only the -! simplices and convex combination weights are returned. -! -! EPS contains the real working precision for the problem on input. By default, -! EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff for the -! machine. In general, any values that differ by less than EPS are judged -! as equal, and any weights that are greater than -EPS are judged as -! nonnegative. EPS cannot take a value less than the default value of -! \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, the default -! value will be used instead automatically. -! -! EXTRAP contains the real maximum extrapolation distance (relative to the -! diameter of PTS) on input. Interpolation at a point outside the convex -! hull of PTS is done by projecting that point onto the convex hull, and -! then doing normal Delaunay interpolation at that projection. -! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) -! units outside the convex hull of PTS will not be done and an error code -! of 2 will be returned. Note that computing the projection can be -! expensive. Setting EXTRAP=0 will cause all extrapolation points to be -! ignored without ever computing a projection. By default, EXTRAP=0.1 -! (extrapolate by up to 10% of the diameter of PTS). -! -! RNORM(1:M) contains the real unscaled projection (2-norm) distances from -! any projection computations on output. If not present, these distances -! are still computed for each extrapolation point, but are never returned. -! -! IBUDGET on input contains the integer budget for performing flips while -! iterating toward the simplex containing each interpolation point in -! Q. This prevents DELAUNAYSPARSES from falling into an infinite loop when -! an inappropriate value of EPS is given with respect to the problem -! conditioning. By default, IBUDGET=50000. However, for extremely -! high-dimensional problems and pathological inputs, the default value -! may be insufficient. -! -! CHAIN is a logical input argument that determines whether a new first -! simplex should be constructed for each interpolation point -! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." -! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not -! recommended, unless the size of the triangulation is relatively small -! or the interpolation points are known to be tightly clustered. -! -! EXACT is a logical input argument that determines whether the exact -! diameter should be computed and whether a check for duplicate data -! points should be performed in advance. When EXACT=.FALSE., the -! diameter of PTS is approximated by twice the distance from the -! barycenter of PTS to the farthest point in PTS, and no check is -! done to find the closest pair of points, which could result in hard -! to find bugs later on. When EXACT=.TRUE., the exact diameter is -! computed and an error is returned whenever PTS contains duplicate -! values up to the precision EPS. By default EXACT=.TRUE., but setting -! EXACT=.FALSE. could result in significant speedup when N is large. -! It is strongly recommended that most users leave EXACT=.TRUE., as -! setting EXACT=.FALSE. could result in input errors that are difficult -! to identify. Also, the diameter approximation could be wrong by up to -! a factor of two. -! -! -! Subroutines and functions directly referenced from BLAS are -! DDOT, DGEMV, DNRM2, DTRSM, -! and from LAPACK are -! DGEQP3, DGETRF, DGETRS, DORMQR. -! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its -! SLATEC dependencies have been slightly edited to comply with the Fortran -! 2008 standard, with all print statements and references to stderr being -! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 -! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS -! Algorithm 777) is used for the real data type. The REAL_PRECISION module, -! DELAUNAYSPARSES, and DWNNLS and its dependencies comply with the Fortran -! 2008 standard. -! -! Primary Author: Tyler H. Chang -! Last Update: March, 2020 -! -USE REAL_PRECISION, ONLY : R8 -IMPLICIT NONE - -! Input arguments. -INTEGER, INTENT(IN) :: D, N -REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) ! Rescaled on output. -INTEGER, INTENT(IN) :: M -REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) ! Rescaled on output. -! Output arguments. -INTEGER, INTENT(OUT) :: SIMPS(:,:) -REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) -INTEGER, INTENT(OUT) :: IERR(:) -! Optional arguments. -REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) -REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) -REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP -REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) -INTEGER, INTENT(IN), OPTIONAL :: IBUDGET -LOGICAL, INTENT(IN), OPTIONAL :: CHAIN -LOGICAL, INTENT(IN), OPTIONAL :: EXACT - -! Local copies of optional input arguments. -REAL(KIND=R8) :: EPSL, EXTRAPL -INTEGER :: IBUDGETL -LOGICAL :: CHAINL, EXACTL - -! Local variables. -INTEGER :: I, J, K ! Loop iteration variables. -INTEGER :: IEXTRAPS ! Extrapolation budget. -INTEGER :: ITMP, JTMP ! Temporary variables for swapping, looping, etc. -INTEGER :: LWORK ! Size of the work array. -INTEGER :: MI ! Index of current interpolation point. -REAL(KIND=R8) :: CURRRAD ! Radius of the current circumsphere. -REAL(KIND=R8) :: MINRAD ! Minimum circumsphere radius observed. -REAL(KIND=R8) :: PTS_DIAM ! Scaled diameter of data set. -REAL(KIND=R8) :: PTS_SCALE ! Data scaling factor. -REAL(KIND=R8) :: RNORML ! Euclidean norm of the projection residual. -REAL(KIND=R8) :: SIDE1, SIDE2 ! Signs (+/-1) denoting sides of a facet. - -! Local arrays, requiring O(d^2) additional memory. -INTEGER :: IPIV(D) ! Pivot indices. -INTEGER :: SEED(D+1) ! Copy of the SEED simplex. Only used if CHAIN = .TRUE. -REAL(KIND=R8) :: AT(D,D) ! The transpose of A, the linear coefficient matrix. -REAL(KIND=R8) :: B(D) ! The RHS of a linear system. -REAL(KIND=R8) :: CENTER(D) ! The circumcenter of a simplex. -REAL(KIND=R8) :: LQ(D,D) ! Holds LU or QR factorization of AT. -REAL(KIND=R8) :: PLANE(D+1) ! The hyperplane containing a facet. -REAL(KIND=R8) :: PRGOPT_DWNNLS(1) ! Options array for DWNNLS. -REAL(KIND=R8) :: PROJ(D) ! The projection of the current iterate. -REAL(KIND=R8) :: TAU(D) ! Householder reflector constants. -REAL(KIND=R8) :: X(D) ! The solution to a linear system. - -! Extrapolation work arrays are only allocated if DWNNLS is called. -INTEGER, ALLOCATABLE :: IWORK_DWNNLS(:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: W_DWNNLS(:,:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: WORK(:) ! Allocated with size LWORK. -REAL(KIND=R8), ALLOCATABLE :: WORK_DWNNLS(:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: X_DWNNLS(:) ! Only for DWNNLS. - -! External functions and subroutines. -REAL(KIND=R8), EXTERNAL :: DDOT ! Inner product (BLAS). -REAL(KIND=R8), EXTERNAL :: DNRM2 ! Euclidean norm (BLAS). -EXTERNAL :: DGEMV ! General matrix vector multiply (BLAS) -EXTERNAL :: DGEQP3 ! Perform a QR factorization with column pivoting (LAPACK). -EXTERNAL :: DGETRF ! Perform a LU factorization with partial pivoting (LAPACK). -EXTERNAL :: DGETRS ! Use the output of DGETRF to solve a linear system (LAPACK). -EXTERNAL :: DORMQR ! Apply householder reflectors to a matrix (LAPACK). -EXTERNAL :: DTRSM ! Perform a triangular solve (BLAS). -EXTERNAL :: DWNNLS ! Solve an inequality constrained least squares problem - ! (SLATEC). - -! Check for input size and dimension errors. -IF (D < 1) THEN ! The dimension must satisfy D > 0. - IERR(:) = 10; RETURN; END IF -IF (N < D+1) THEN ! Must have at least D+1 data points. - IERR(:) = 11; RETURN; END IF -IF (M < 1) THEN ! Must have at least one interpolation point. - IERR(:) = 12; RETURN; END IF -IF (SIZE(PTS,1) .NE. D) THEN ! Dimension of PTS array should match. - IERR(:) = 13; RETURN; END IF -IF (SIZE(PTS,2) .NE. N) THEN ! Number of data points should match. - IERR(:) = 14; RETURN; END IF -IF (SIZE(Q,1) .NE. D) THEN ! Dimension of Q should match. - IERR(:) = 15; RETURN; END IF -IF (SIZE(Q,2) .NE. M) THEN ! Number of interpolation points should match. - IERR(:) = 16; RETURN; END IF -IF (SIZE(SIMPS,1) .NE. D+1) THEN ! Need space for D+1 vertices per simplex. - IERR(:) = 17; RETURN; END IF -IF (SIZE(SIMPS,2) .NE. M) THEN ! There will be M output simplices. - IERR(:) = 18; RETURN; END IF -IF (SIZE(WEIGHTS,1) .NE. D+1) THEN ! There will be D+1 weights per simplex. - IERR(:) = 19; RETURN; END IF -IF (SIZE(WEIGHTS,2) .NE. M) THEN ! One vector of weights per simplex. - IERR(:) = 20; RETURN; END IF -IF (SIZE(IERR) .NE. M) THEN ! An error flag for each interpolation point. - IERR(:) = 21; RETURN; END IF - -! Check for optional arguments. -IF (PRESENT(INTERP_IN) .NEQV. PRESENT(INTERP_OUT)) THEN - IERR(:) = 22; RETURN; END IF -IF (PRESENT(INTERP_IN)) THEN ! Sizes must agree. - IF (SIZE(INTERP_IN,1) .NE. SIZE(INTERP_OUT,1)) THEN - IERR(:) = 23 ; RETURN; END IF - IF(SIZE(INTERP_IN,2) .NE. N) THEN - IERR(:) = 24; RETURN; END IF - IF (SIZE(INTERP_OUT,2) .NE. M) THEN - IERR(:) = 25; RETURN; END IF - INTERP_OUT(:,:) = 0.0_R8 ! Initialize output to zeros. -END IF -EPSL = SQRT(EPSILON(0.0_R8)) ! Get the machine unit roundoff constant. -IF (PRESENT(EPS)) THEN - IF (EPSL < EPS) THEN ! If the given precision is too small, ignore it. - EPSL = EPS - END IF -END IF -IF (PRESENT(IBUDGET)) THEN - IBUDGETL = IBUDGET ! Use the given budget if present. - IF (IBUDGETL < 1) THEN - IERR(:) = 26; RETURN; END IF -ELSE - IBUDGETL = 50000 ! Default value for budget. -END IF -IF (PRESENT(EXTRAP)) THEN - EXTRAPL = EXTRAP - IF (EXTRAPL < 0) THEN ! Check that the extrapolation distance is legal. - IERR(:) = 27; RETURN; END IF -ELSE - EXTRAPL = 0.1_R8 ! Default extrapolation distance (for normalized points). -END IF -IF (PRESENT(RNORM)) THEN - IF (SIZE(RNORM,1) .NE. M) THEN ! The length of the array must match. - IERR(:) = 28; RETURN; END IF - RNORM(:) = 0.0_R8 ! Initialize output to zeros. -END IF -IF (PRESENT(CHAIN)) THEN - CHAINL = CHAIN ! Turn chaining on, if necessarry. - SEED(:) = 0 ! Initialize SEED in case it is needed. -ELSE - CHAINL = .FALSE. -END IF -IF (PRESENT(EXACT)) THEN - EXACTL = EXACT ! Set error checking and exact diameter computations. -ELSE - EXACTL = .TRUE. -END IF - -! Scale and center the data points and interpolation points. -CALL RESCALE(MINRAD, PTS_DIAM, PTS_SCALE) -IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. - IERR(:) = 30; RETURN; END IF - -! Query DGEQP3 for optimal work array size (LWORK). -LWORK = -1 -CALL DGEQP3(D,D,LQ,D,IPIV,TAU,B,LWORK,IERR(1)) -LWORK = INT(B(1)) ! Compute the optimal work array size. -ALLOCATE(WORK(LWORK), STAT=I) ! Allocate WORK to size LWORK. -IF (I .NE. 0) THEN ! Check for memory allocation errors. - IERR(:) = 50; RETURN; END IF - -! Initialize all error codes to "TBD" values. -IERR(:) = 40 - -! Outer loop over all interpolation points (in Q). -OUTER : DO MI = 1, M - - ! Check if this interpolation point was already found. - IF (IERR(MI) .EQ. 0) CYCLE OUTER - - ! Initialize the projection and reset the residual. - PROJ(:) = Q(:,MI) - RNORML = 0.0_R8 - - ! Check if extrapolation is enabled. - IF (EXTRAPL < EPSL) THEN - IEXTRAPS = -1 ! If not, set the extrapolation budget negative. - ELSE - IEXTRAPS = 1 ! Allow for exactly one projection for this point. - END IF - - ! If there is no useable seed or if chaining is turned off, then make a new - ! simplex. - IF( (.NOT. CHAINL) .OR. SEED(1) .EQ. 0) THEN - CALL MAKEFIRSTSIMP() - IF(IERR(MI) .NE. 0) CYCLE OUTER - ! Otherwise, use the seed. - ELSE - ! Copy the seed to the current simplex. - SIMPS(:,MI) = SEED(:) - ! Rebuild the linear system. - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - - ! Inner loop searching for a simplex containing the point Q(:,MI). - INNER : DO K = 1, IBUDGETL - - ! If chaining is on, save each good simplex as the next seed. - IF (CHAINL) SEED(:) = SIMPS(:,MI) - - ! Check if the current simplex contains Q(:,MI). - IF (PTINSIMP()) EXIT INNER - IF (IERR(MI) .NE. 0) CYCLE OUTER ! Check for an error flag. - - ! Swap out the least weighted vertex, but save its value in case it - ! needs to be restored later. - JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) - ITMP = SIMPS(JTMP,MI) - SIMPS(JTMP,MI) = SIMPS(D+1,MI) - - ! If the least weighted vertex (index JTMP) is not the first vertex, - ! then just drop row (JTMP-1) from the linear system (corresponding - ! to column (JTMP-1) of A^T). - IF(JTMP .NE. 1) THEN - AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) - ! However, if JTMP = 1, then both A^T and B must be reconstructed. - ELSE - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - - ! Compute the next simplex (do one flip). - CALL MAKESIMPLEX() - IF (IERR(MI) .NE. 0) CYCLE OUTER - - ! If no vertex was found, then this is an extrapolation point. - IF (SIMPS(D+1,MI) .EQ. 0) THEN - - ! If extrapolation is not allowed (EXTRAP=0), do not proceed. - IF (IEXTRAPS < 0) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! Set the error flag and skip this point. - IERR(MI) = 2; CYCLE OUTER - - ! If extrapolation is allowed (EXTRAP>0), check the budget. - ELSE IF (IEXTRAPS .EQ. 0) THEN - ! A second projection has been attempted. This code is rarely - ! called, except in extreme cases involving nearly singular - ! simplices near the convex hull of P. - - ! Swap the weights to match the simplex indices, and zero the - ! most negative weight. - WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) - WEIGHTS(D+1,MI) = 0.0_R8 - ! Loop through all the remaining facets from which Q(:,MI) is - ! visible, and attempt to flip across each one. - DO WHILE (SIMPS(D+1,MI) .EQ. 0) - ! Restore the previous simplex and linear system. - SIMPS(D+1,MI) = ITMP - AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - ! Find the next most negative weight. - JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) - ! Check if WEIGHTS(JTMP,MI) .GE. 0. - IF (WEIGHTS(JTMP,MI) .GE. -EPSL) THEN - ! There is no other direction to flip, so Q(:,MI) must be - ! within EPSL of the current simplex. - ! Project Q(:,MI) onto the current simplex. - - ! Since at least one projection has already been done, - ! the work arrays have already been allocated. - PRGOPT_DWNNLS(1) = 1.0_R8 - IWORK_DWNNLS(1) = 6*D + 6 - IWORK_DWNNLS(2) = 2*D + 2 - ! Set equality constraint. - W_DWNNLS(1,1:D+2) = 1.0_R8 - ! Populate LS coefficient matrix and RHS. - FORALL (I=1:D+1) W_DWNNLS(2:D+1,I) = PTS(:,SIMPS(I,MI)) - W_DWNNLS(2:D+1,D+2) = PROJ(:) - ! Project onto the current simplex. - CALL DWNNLS(W_DWNNLS, D+1, 1, D, D+1, 0, PRGOPT_DWNNLS, & - WEIGHTS(:,MI), WORK(1), IERR(MI), IWORK_DWNNLS, & - WORK_DWNNLS) - IF (IERR(MI) .EQ. 1) THEN ! Failure to converge. - IERR(MI) = 71; CYCLE OUTER - ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. - IERR(MI) = 72; CYCLE OUTER - END IF - ! A solution has been found; return it. - EXIT INNER - END IF - ! Otherwise, swap the vertices. - ITMP = SIMPS(JTMP,MI) - SIMPS(JTMP,MI) = SIMPS(D+1,MI) - ! Swap the weights to match, and zero the most negative weight. - WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) - WEIGHTS(D+1,MI) = 0.0_R8 - ! If the least weighted vertex (index JTMP) is not the first - ! vertex, then just drop row (JTMP-1) from the linear system - ! (corresponding to column (JTMP-1) of A^T). - IF (JTMP .NE. 1) THEN - AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) - ! However, if JTMP=1, then both A^T and B must be reconstructed. - ELSE - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - ! Compute another simplex (try to flip again). - CALL MAKESIMPLEX(); IF (IERR(MI) .NE. 0) CYCLE OUTER - END DO - ! If the loop terminates, then a good direction was found. - ! Resume the visibility walk as normal. - CYCLE INNER - END IF - - ! Otherwise, project the extrapolation point onto the convex hull. - CALL PROJECT() - IF (IERR(MI) .NE. 0) CYCLE OUTER - - ! Check the value of RNORML for over-extrapolation. - IF (RNORML > EXTRAPL * PTS_DIAM) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! If present, record the unscaled RNORM output. - IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE - ! Set the error flag and skip this point. - IERR(MI) = 2; CYCLE OUTER - END IF - - ! Otherwise, restore the previous simplex and continue with the - ! projected value. - SIMPS(D+1,MI) = ITMP - AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - IEXTRAPS = IEXTRAPS - 1 ! Decrement the budget. - END IF - - ! End of inner loop for finding each interpolation point. - END DO INNER - - ! Check for budget violation conditions. - IF (K > IBUDGETL) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! Set the error flag and skip this point. - IERR(MI) = 60; CYCLE OUTER - END IF - - ! If the residual is nonzero, set the extrapolation flag. - IF (RNORML > EPSL) IERR(MI) = 1 - - ! If present, record the RNORM output. - IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE - -END DO OUTER ! End of outer loop over all interpolation points. - -! If INTERP_IN and INTERP_OUT are present, compute all values f(q). -IF (PRESENT(INTERP_IN)) THEN - ! Loop over all interpolation points. - DO MI = 1, M - ! Check for errors. - IF (IERR(MI) .LE. 1) THEN - ! Compute the weighted sum of vertex response values. - DO K = 1, D+1 - INTERP_OUT(:,MI) = INTERP_OUT(:,MI) & - + INTERP_IN(:,SIMPS(K,MI)) * WEIGHTS(K,MI) - END DO - END IF - END DO -END IF - -! Free dynamic work arrays. -DEALLOCATE(WORK) -IF (ALLOCATED(IWORK_DWNNLS)) DEALLOCATE(IWORK_DWNNLS) -IF (ALLOCATED(WORK_DWNNLS)) DEALLOCATE(WORK_DWNNLS) -IF (ALLOCATED(W_DWNNLS)) DEALLOCATE(W_DWNNLS) -IF (ALLOCATED(X_DWNNLS)) DEALLOCATE(X_DWNNLS) - -RETURN - -CONTAINS ! Internal subroutines and functions. - -SUBROUTINE MAKEFIRSTSIMP() -! Iteratively construct the first simplex by choosing points that -! minimize the radius of the smallest circumball. Let P_1, P_2, ..., P_K -! denote the current set of vertices for the simplex. Let P* denote the -! candidate vertex to be added to the simplex. Let CENTER denote the -! circumcenter of the simplex. Then -! -! X = CENTER - P_1 -! -! is given by the minimum norm solution to the underdetermined linear system -! -! A X = B, where -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_K - P_1, P* - P_1 ] and -! B = [ /2, /2, ..., /2 ]^T. -! -! Then the radius of the smallest circumsphere is CURRRAD = \| X \|, -! and the next vertex is given by P_{K+1} = argmin_{P*} CURRRAD, where P* -! ranges over points in PTS that are not already a vertex of the simplex. -! -! On output, this subroutine fully populates the matrix A^T and vector B, -! and fills SIMPS(:,MI) with the indices of a valid Delaunay simplex. - -! Find the first point, i.e., the closest point to Q(:,MI). -SIMPS(:,MI) = 0 -MINRAD = HUGE(0.0_R8) -DO I = 1, N - ! Check the distance to Q(:,MI). - CURRRAD = DNRM2(D, PTS(:,I) - PROJ(:), 1) - IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(1,MI) = I; END IF -END DO -! Find the second point, i.e., the closest point to PTS(:,SIMPS(1,MI)). -MINRAD = HUGE(0.0_R8) -DO I = 1, N - ! Skip repeated vertices. - IF (I .EQ. SIMPS(1,MI)) CYCLE - ! Check the diameter of the resulting circumsphere. - CURRRAD = DNRM2(D, PTS(:,I)-PTS(:,SIMPS(1,MI)), 1) - IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(2,MI) = I; END IF -END DO -IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. - IERR(MI) = 30; RETURN; END IF -! Set up the first row of the linear system. -AT(:,1) = PTS(:,SIMPS(2,MI)) - PTS(:,SIMPS(1,MI)) -B(1) = DDOT(D, AT(:,1), 1, AT(:,1), 1) / 2.0_R8 -! Loop to collect the remaining D-1 vertices for the first simplex. -DO I = 2, D - ! For numerical stability, refactor A^T P = Q R for the next iteration. - LQ(:,1:I-1) = AT(:,1:I-1) - CALL DGEQP3(D, I-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 80; RETURN - END IF - ! Set the RHS to P^T B. - FORALL (ITMP = 1:I-1) X(ITMP) = B(IPIV(ITMP)) - ! Solve R^T Q^T X = P^T B for Q^T X, and save for later. - CALL DTRSM('L', 'U', 'T', 'N', I-1, 1, 1.0_R8, LQ, D, X, D) - ! Make a copy for computing the current center. - CENTER(1:I-1) = X(1:I-1) - CENTER(I:D) = 0.0_R8 - ! Apply Q from the left. - CALL DORMQR('L', 'N', D, 1, I-1, LQ, D, TAU, CENTER, D, WORK, & - LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 83; RETURN - END IF - CENTER = CENTER + PTS(:,SIMPS(1,MI)) - ! Re-initialize the radius for each iteration. - MINRAD = HUGE(0.0_R8) - ! Check each point P* in PTS. - DO J = 1, N - ! Check that this point is not already in the simplex. - IF (ANY(SIMPS(:,MI) .EQ. J)) CYCLE - ! If PTS(:,J) is more than twice MINRAD from CENTER, do a quick skip. - IF (DNRM2(D, CENTER - PTS(:,J), 1) > 2.0_R8 * MINRAD) CYCLE - ! Perform a rank-1 update to the current QR factorization of A^T by - ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI)) by Q^T and storing in the - ! final column of R. - LQ(:,I) = PTS(:,J) - PTS(:,SIMPS(1,MI)) - CALL DORMQR('L', 'T', D, 1, I-1, LQ(:,1:I-1), D, TAU, LQ(:,I), D, & - WORK, LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 83; RETURN - END IF - ! Implicitly apply the next Householder reflector. - LQ(I,I) = DNRM2(D+1-I, LQ(I:D,I), 1) - IF (LQ(I,I) < EPSL) THEN ! A is rank-deficient. - CYCLE ! If rank-deficient, skip this point. - END IF - ! Update the current radius by \| Q^T X \| = \| X \|. - WORK(1:I-1) = (LQ(1:I-1,I) / 2.0_R8) - X(1:I-1) - WORK(I) = LQ(I,I) / 2.0_R8 - X(I) = DDOT(I, LQ(1:I,I), 1, WORK(1:I), 1) / LQ(I,I) - CURRRAD = DNRM2(I, X(1:I), 1) - ! Compare the last component of Q^T X to the current minimum. - IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(I+1,MI) = J; END IF - END DO - ! Check that a point was found. If not, then all the points must lie in a - ! lower dimensional linear manifold (error case). - IF (SIMPS(I+1,MI) .EQ. 0) THEN; IERR(MI) = 31; RETURN; END IF - ! If all operations were successful, add the best P* to the linear system. - AT(:,I) = PTS(:,SIMPS(I+1,MI)) - PTS(:,SIMPS(1,MI)) - B(I) = DDOT(D, AT(:,I), 1, AT(:,I), 1) / 2.0_R8 -END DO -IERR(MI) = 0 ! Set error flag to 'success' for a normal return. -RETURN -END SUBROUTINE MAKEFIRSTSIMP - -SUBROUTINE MAKESIMPLEX() -! Given a Delaunay facet F whose containing hyperplane does not contain -! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' -! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F -! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the -! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly -! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing -! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices -! P_1, P_2, ..., P_D, P*. Then -! -! X = CENTER - P_1 -! -! is given by the solution to the nonsingular linear system -! -! A X = B where -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and -! B = [ /2, /2, ..., /2 ]^T. -! -! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the -! candidate P* that satisfies both of the following: -! -! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) -! must be on the same side of PLANE. -! -! 2) The circumball about CENTER must not contain any points in PTS in its -! interior (Delaunay property). -! -! The above are necessary and sufficient conditions for flipping the -! Delaunay simplex, given that F is indeed a Delaunay facet. -! -! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices -! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex -! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and -! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were -! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an -! extrapolation point (not a convex combination of points in PTS). - -! Compute the hyperplane PLANE. -CALL MAKEPLANE() -IF(IERR(MI) .NE. 0) RETURN ! Check for errors. -! Compute the sign for the side of PLANE containing Q(:,MI). -SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) -SIDE1 = SIGN(1.0_R8,SIDE1) -! Initialize the center, radius, and simplex. -SIMPS(D+1,MI) = 0 -CENTER(:) = 0.0_R8 -MINRAD = HUGE(0.0_R8) -! If D=1, just check for the closest point on SIDE1 of PTS(:,SIMPS(1,MI)). -IF (D .EQ. 1) THEN - ! Loop through all points P* in PTS. - DO I = 1, N - ! Check that P* is on the appropriate halfspace. - SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 - IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE - ! Check that P* is closer than the current solution. - IF (SIDE2 > MINRAD) CYCLE - ! Update the minimum distance and save the index I. - MINRAD = SIDE2 - SIMPS(2,MI) = I - END DO - IERR(MI) = 0 ! Reset the error flag to 'success' code. - ! Check for extrapolation condition. - IF(SIMPS(2,MI) .EQ. 0) RETURN - ! Add new point to the linear system. - AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) - B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 - RETURN -END IF -! Set the RHS to P^T B. -FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) -! Solve R^T Q^T X = P^T B for Q^T X. -CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) -! Loop through all points P* in PTS. -DO I = 1, N - ! Check that P* is inside the current ball. - IF (DNRM2(D, PTS(:,I) - CENTER(:), 1) > MINRAD) CYCLE ! If not, skip. - ! Check that P* is on the appropriate halfspace. - SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) - IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE ! If not, skip. - ! Perform a rank-1 update to the current QR factorization of A^T by - ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the - ! final column of R. - LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) - CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & - LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 83; RETURN - END IF - ! Update the last element of Q^T X. - WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) - WORK(D) = LQ(D,D) / 2.0_R8 - CENTER(1:D-1) = X(1:D-1) - CENTER(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) - ! Get the center by applying Q to the solution. - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER, D, WORK, LWORK, & - IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 83; RETURN - END IF - ! Update the new radius, center, and simplex. - MINRAD = DNRM2(D, CENTER, 1) - CENTER(:) = CENTER(:) + PTS(:,SIMPS(1,MI)) - SIMPS(D+1,MI) = I -END DO -IERR(MI) = 0 ! Reset the error flag to 'success' code. -! Check for extrapolation condition. -IF(SIMPS(D+1,MI) .EQ. 0) RETURN -! Add new point to the linear system. -AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) -B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 -RETURN -END SUBROUTINE MAKESIMPLEX - -SUBROUTINE MAKEPLANE() -! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed -! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. -! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal -! vector is any nonzero vector in ker A, where the matrix -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. -! -! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR -! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. -! Then the last column of Q is orthogonal to the range of A^T, and in ker A. -! -! Upon output, PLANE(1:D) contains the normal vector c and PLANE(D+1) -! contains \alpha defining the plane. Also, LQ, IPIV, and TAU define a QR -! factorizaton of the first D-1 columns of A^T. - -IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. - ! Compute the QR factorization. - IPIV=0 - LQ = AT - CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 80; RETURN - END IF - ! The nullspace is given by the last column of Q. - PLANE(1:D-1) = 0.0_R8 - PLANE(D) = 1.0_R8 - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & - LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 83; RETURN - END IF - ! Calculate the constant \alpha defining the plane. - PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) -ELSE ! Special case where D=1. - PLANE(1) = 1.0_R8 - PLANE(2) = PTS(1,SIMPS(1,MI)) -END IF -RETURN -END SUBROUTINE MAKEPLANE - -FUNCTION PTINSIMP() RESULT(TF) -! Determine if any interpolation points are in the current simplex, whose -! vertices P_1, P_2, ..., P_{D+1} are indexed by SIMPS(:,MI). These -! vertices determine a positive cone with generators V_I = P_{I+1} - P_1, -! I = 1, ..., D. For each interpolation point Q* in Q, Q* - P_1 can be -! expressed as a unique linear combination of the V_I. If all these linear -! weights are nonnegative and sum to less than or equal to 1.0, then Q* is -! in the simplex with vertices {P_I}_{I=1}^{D+1}. -! -! If any interpolation points in Q are contained in the simplex whose -! vertices are indexed by SIMPS(:,MI), then those points are marked as solved -! and the values of SIMPS and WEIGHTS are updated appropriately. On output, -! WEIGHTS(:,MI) contains the affine weights for producing Q(:,MI) as an -! affine combination of the points in PTS indexed by SIMPS(:,MI). If these -! weights are nonnegative, then PTINSIMP() returns TRUE. - -! Initialize the return value and local variables. -LOGICAL :: TF ! True/False value. -TF = .FALSE. - -! Compute the LU factorization of the matrix A^T, whose columns are -! P_{I+1} - P_1. -LQ = AT -CALL DGETRF(D, D, LQ, D, IPIV, IERR(MI)) -IF (IERR(MI) < 0) THEN ! LAPACK illegal input. - IERR(MI) = 81; RETURN -ELSE IF (IERR(MI) > 0) THEN ! Rank-deficiency detected. - IERR(MI) = 61; RETURN -END IF -! Solve A^T w = WORK to get the affine weights for Q(:,MI) or its projection. -WORK(1:D) = PROJ(:) - PTS(:,SIMPS(1,MI)) -CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(1:D), D, IERR(MI)) -IF (IERR(MI) < 0) THEN ! LAPACK illegal input. - IERR(MI) = 82; RETURN -END IF -WEIGHTS(2:D+1,MI) = WORK(1:D) -WEIGHTS(1,MI) = 1.0_R8 - SUM(WEIGHTS(2:D+1,MI)) -! Check if the weights for Q(:,MI) are nonnegative. -IF (ALL(WEIGHTS(:,MI) .GE. -EPSL)) TF = .TRUE. - -! Compute the affine weights for the rest of the interpolation points. -DO I = MI+1, M - ! Check that no solution has already been found. - IF (IERR(I) .NE. 40) CYCLE - ! Solve A^T w = WORK to get the affine weights for Q(:,I). - WORK(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) - CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(2:D+1), D, ITMP) - IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. - ! Check if the weights define a convex combination. - WORK(1) = 1.0_R8 - SUM(WORK(2:D+1)) - IF (ALL(WORK(1:D+1) .GE. -EPSL)) THEN - ! Copy the simplex indices and weights then flag as complete. - SIMPS(:,I) = SIMPS(:,MI) - WEIGHTS(:,I) = WORK(1:D+1) - IERR(I) = 0 - END IF -END DO -RETURN -END FUNCTION PTINSIMP - -SUBROUTINE PROJECT() -! Project a point outside the convex hull of the point set onto the convex hull -! by solving an inequality constrained least squares problem. The solution to -! the least squares problem gives the projection as a convex combination of the -! data points. The projection can then be computed by performing a matrix -! vector multiplication. - -! Allocate work arrays. -IF (.NOT. ALLOCATED(IWORK_DWNNLS)) THEN - ALLOCATE(IWORK_DWNNLS(D+1+N), STAT=IERR(MI)) - IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF -END IF -IF (.NOT. ALLOCATED(WORK_DWNNLS)) THEN - ALLOCATE(WORK_DWNNLS(D+1+N*5), STAT=IERR(MI)) - IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF -END IF -IF (.NOT. ALLOCATED(W_DWNNLS)) THEN - ALLOCATE(W_DWNNLS(D+1,N+1), STAT=IERR(MI)) - IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF -END IF -IF (.NOT. ALLOCATED(X_DWNNLS)) THEN - ALLOCATE(X_DWNNLS(N), STAT=IERR(MI)) - IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF -END IF - -! Initialize work array and settings values. -PRGOPT_DWNNLS(1) = 1.0_R8 -IWORK_DWNNLS(1) = D+1+5*N -IWORK_DWNNLS(2) = D+1+N -W_DWNNLS(1, :) = 1.0_R8 ! Set convexity (equality) constraint. -W_DWNNLS(2:D+1,1:N) = PTS(:,:) ! Copy data points. -W_DWNNLS(2:D+1,N+1) = PROJ(:) ! Copy extrapolation point. -! Compute the solution to the inequality constrained least squares problem to -! get the projection coefficients. -CALL DWNNLS(W_DWNNLS, D+1, 1, D, N, 0, PRGOPT_DWNNLS, X_DWNNLS, RNORML, & - IERR(MI), IWORK_DWNNLS, WORK_DWNNLS) -IF (IERR(MI) .EQ. 1) THEN ! Failure to converge. - IERR(MI) = 71; RETURN -ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. - IERR(MI) = 72; RETURN -END IF -! Zero all weights that are approximately zero and renormalize the sum. -WHERE (X_DWNNLS < EPSL) X_DWNNLS = 0.0_R8 -X_DWNNLS(:) = X_DWNNLS(:) / SUM(X_DWNNLS) -! Compute the actual projection via matrix vector multiplication. -CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) -RNORML = DNRM2(D, PROJ(:) - Q(:,MI), 1) -RETURN -END SUBROUTINE PROJECT - -SUBROUTINE RESCALE(MINDIST, DIAMETER, SCALE) -! Rescale and transform data to be centered at the origin with unit -! radius. This subroutine has O(n^2) complexity. -! -! On output, PTS and Q have been rescaled and shifted. All the data -! points in PTS are centered with unit radius, and the points in Q -! have been shifted and scaled in relation to PTS. -! -! MINDIST is a real number containing the (scaled) minimum distance -! between any two data points in PTS. -! -! DIAMETER is a real number containing the (scaled) diameter of the -! data set PTS. -! -! SCALE contains the real factor used to transform the data and -! interpolation points: scaled value = (original value - -! barycenter of data points)/SCALE. - -! Output arguments. -REAL(KIND=R8), INTENT(OUT) :: MINDIST, DIAMETER, SCALE - -! Local variables. -REAL(KIND=R8) :: PTS_CENTER(D) ! The center of the data points PTS. -REAL(KIND=R8) :: DISTANCE ! The current distance. - -! Initialize local values. -MINDIST = HUGE(0.0_R8) -DIAMETER = 0.0_R8 -SCALE = 0.0_R8 - -! Compute barycenter of all data points. -PTS_CENTER(:) = SUM(PTS(:,:), DIM=2)/REAL(N, KIND=R8) -! Center the points. -FORALL (I = 1:N) PTS(:,I) = PTS(:,I) - PTS_CENTER(:) -! Compute the scale factor (for unit radius). -DO I = 1, N ! Cycle through all points again. - DISTANCE = DNRM2(D, PTS(:,I), 1) ! Compute the distance from the center. - IF (DISTANCE > SCALE) THEN ! Compare to the current radius. - SCALE = DISTANCE - END IF -END DO -! Scale the points to unit radius. -PTS = PTS / SCALE -! Also transform Q similarly. -FORALL (I = 1:M) Q(:,I) = (Q(:,I) - PTS_CENTER(:)) / SCALE -! Compute the minimum and maximum distances. -IF (EXACTL) THEN - ! If exact error error checking is turned on, then compute the DIAMETER - ! and MINDIST values. - DO I = 1, N ! Cycle through all pairs of points. - DO J = I + 1, N - DISTANCE = DNRM2(D, PTS(:,I) - PTS(:,J), 1) ! Compute the distance. - IF (DISTANCE > DIAMETER) THEN ! Compare to the current diameter. - DIAMETER = DISTANCE - END IF - IF (DISTANCE < MINDIST) THEN ! Compare to the current minimum distance. - MINDIST = DISTANCE - END IF - END DO - END DO -ELSE - ! If exact error checking is turned off, then the diameter is approximately - ! 2.0 after rescaling and centering the points. The MINDIST is not computed. - DIAMETER = 2.0_R8 - MINDIST = 1.0_R8 -END IF -RETURN -END SUBROUTINE RESCALE - -END SUBROUTINE DELAUNAYSPARSES - - -SUBROUTINE DELAUNAYSPARSEP( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EXACT, & - PMODE ) -! This is a parallel implementation of an algorithm for efficiently performing -! interpolation in R^D via the Delaunay triangulation. The algorithm is fully -! described and analyzed in -! -! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. -! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate -! interpolation in arbitrary dimension via the Delaunay triangulation. In -! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, -! USA. Article 12, 8 pages. -! -! -! On input: -! -! D is the dimension of the space for PTS and Q. -! -! N is the number of data points in PTS. -! -! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the -! coordinates of a single data point in R^D. -! -! M is the number of interpolation points in Q. -! -! Q(1:D,1:M) is a real valued matrix with M columns, each containing the -! coordinates of a single interpolation point in R^D. -! -! -! On output: -! -! PTS and Q have been rescaled and shifted. All the data points in PTS -! are now contained in the unit hyperball in R^D, and the points in Q -! have been shifted and scaled accordingly in relation to PTS. -! -! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns -! in PTS) for the D+1 vertices of the Delaunay simplex containing each -! interpolation point in Q. -! -! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each -! point in Q as a convex combination of the D+1 corresponding vertices -! in SIMPS. -! -! IERR(1:M) contains integer valued error flags associated with the -! computation of each of the M interpolation points in Q. The error -! codes are: -! -! 00 : Succesful interpolation. -! 01 : Succesful extrapolation (up to the allowed extrapolation distance). -! 02 : This point was outside the allowed extrapolation distance; the -! corresponding entries in SIMPS and WEIGHTS contain zero values. -! -! 10 : The dimension D must be positive. -! 11 : Too few data points to construct a triangulation (i.e., N < D+1). -! 12 : No interpolation points given (i.e., M < 1). -! 13 : The first dimension of PTS does not agree with the dimension D. -! 14 : The second dimension of PTS does not agree with the number of points N. -! 15 : The first dimension of Q does not agree with the dimension D. -! 16 : The second dimension of Q does not agree with the number of -! interpolation points M. -! 17 : The first dimension of the output array SIMPS does not match the number -! of vertices needed for a D-simplex (D+1). -! 18 : The second dimension of the output array SIMPS does not match the -! number of interpolation points M. -! 19 : The first dimension of the output array WEIGHTS does not match the -! number of vertices for a a D-simplex (D+1). -! 20 : The second dimension of the output array WEIGHTS does not match the -! number of interpolation points M. -! 21 : The size of the error array IERR does not match the number of -! interpolation points M. -! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. -! 23 : The first dimension of INTERP_IN does not match the first -! dimension of INTERP_OUT. -! 24 : The second dimension of INTERP_IN does not match the number of -! data points PTS. -! 25 : The second dimension of INTERP_OUT does not match the number of -! interpolation points M. -! 26 : The budget supplied in IBUDGET does not contain a positive -! integer. -! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. -! 28 : The size of the RNORM output array does not match the number of -! interpolation points M. -! -! 30 : Two or more points in the data set PTS are too close together with -! respect to the working precision (EPS), which would result in a -! numerically degenerate simplex. -! 31 : All the data points in PTS lie in some lower dimensional linear -! manifold (up to the working precision), and no valid triangulation -! exists. -! 40 : An error caused DELAUNAYSPARSEP to terminate before this value could -! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may -! contain garbage values. -! -! 50 : A memory allocation error occurred while allocating the work array -! WORK. -! -! 60 : The budget was exceeded before the algorithm converged on this -! value. If the dimension is high, try increasing IBUDGET. This -! error can also be caused by a working precision EPS that is too -! small for the conditioning of the problem. -! -! 61 : A value that was judged appropriate later caused LAPACK to encounter a -! singularity. Try increasing the value of EPS. -! -! 70 : Allocation error for the extrapolation work arrays. -! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection -! of an extrapolation point onto the convex hull. -! 72 : The SLATEC subroutine DWNNLS has reported a usage error. -! -! The errors 72, 80--83 should never occur, and likely indicate a -! compiler bug or hardware failure. -! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. -! 81 : The LAPACK subroutine DGETRF has reported an illegal value. -! 82 : The LAPACK subroutine DGETRS has reported an illegal value. -! 83 : The LAPACK subroutine DORMQR has reported an illegal value. -! -! 90 : The value of PMODE is not valid. -! -! -! Optional arguments: -! -! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of -! the data points in PTS on input. The first dimension of INTERP_IN is -! inferred to be the dimension of these response vectors, and the -! second dimension must match N. If present, the response values will -! be computed for each interpolation point in Q, and stored in INTERP_OUT, -! which therefore must also be present. If both INTERP_IN and INTERP_OUT -! are omitted, only the containing simplices and convex combination -! weights are returned. -! -! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each -! interpolation point in Q on output. The first dimension of INTERP_OU -! must match the first dimension of INTERP_IN, and the second dimension -! must match M. If present, the response values at each interpolation -! point are computed as a convex combination of the response values -! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing -! that interpolation point. Therefore, if INTERP_OUT is present, then -! INTERP_IN must also be present. If both are omitted, only the -! simplices and convex combination weights are returned. -! -! EPS contains the real working precision for the problem on input. By -! default, EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff -! for the machine. In general, any values that differ by less than EPS -! are judged as equal, and any weights that are greater than -EPS are -! judged as nonnegative. EPS cannot take a value less than the default -! value of \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, -! the default value will be used instead automatically. -! -! EXTRAP contains the real maximum extrapolation distance (relative to the -! diameter of PTS) on input. Interpolation at a point outside the convex -! hull of PTS is done by projecting that point onto the convex hull, and -! then doing normal Delaunay interpolation at that projection. -! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) -! units outside the convex hull of PTS will not be done and an error code -! of 2 will be returned. Note that computing the projection can be -! expensive. Setting EXTRAP=0 will cause all extrapolation points to be -! ignored without ever computing a projection. By default, EXTRAP=0.1 -! (extrapolate by up to 10% of the diameter of PTS). -! -! RNORM(1:M) contains the real unscaled projection (2-norm) distances from -! any projection computations on output. If not present, these distances -! are still computed for each extrapolation point, but are never returned. -! -! IBUDGET on input contains the integer budget for performing flips while -! iterating toward the simplex containing each interpolation point in Q. -! This prevents DELAUNAYSPARSEP from falling into an infinite loop when -! an inappropriate value of EPS is given with respect to the problem -! conditioning. By default, IBUDGET=50000. However, for extremely -! high-dimensional problems and pathological inputs, the default value -! may be insufficient. -! -! CHAIN is a logical input argument that determines whether a new first -! simplex should be constructed for each interpolation point -! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." -! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not -! recommended, unless the size of the triangulation is relatively small -! or the interpolation points are known to be tightly clustered. -! -! EXACT is a logical input argument that determines whether the exact -! diameter should be computed and whether a check for duplicate data -! points should be performed in advance. When EXACT=.FALSE., the -! diameter of PTS is approximated by twice the distance from the -! barycenter of PTS to the farthest point in PTS, and no check is -! done to find the closest pair of points, which could result in hard -! to find bugs later on. When EXACT=.TRUE., the exact diameter is -! computed and an error is returned whenever PTS contains duplicate -! values up to the precision EPS. By default EXACT=.TRUE., but setting -! EXACT=.FALSE. could result in significant speedup when N is large. -! It is strongly recommended that most users leave EXACT=.TRUE., as -! setting EXACT=.FALSE. could result in input errors that are difficult -! to identify. Also, the diameter approximation could be wrong by up to -! a factor of two. -! -! PMODE is an integer specifying the level of parallelism to be exploited. -! If PMODE = 1, then parallelism is exploited at the level of the loop -! over all interpolation points (Level 1 parallelism). -! If PMODE = 2, then parallelism is exploited at the level of the loops -! over data points when constructing/flipping simplices (Level 2 -! parallelism). -! If PMODE = 3, then parallelism is exploited at both levels. Note: this -! implies that the total number of threads active at any time could be up -! to OMP_NUM_THREADS^2. -! By default, PMODE is set to 1 if there is more than 1 interpolation -! point and 2 otherwise. -! -! -! Subroutines and functions directly referenced from BLAS are -! DDOT, DGEMV, DNRM2, DTRSM, -! and from LAPACK are -! DGEQP3, DGETRF, DGETRS, DORMQR. -! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its -! SLATEC dependencies have been slightly edited to comply with the Fortran -! 2008 standard, with all print statements and references to stderr being -! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 -! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS -! Algorithm 777) is used for the real data type. The REAL_PRECISION module, -! DELAUNAYSPARSEP, and DWNNLS and its dependencies comply with the Fortran -! 2008 standard. -! -! Primary Author: Tyler H. Chang -! Last Update: March, 2020 -! -USE REAL_PRECISION, ONLY : R8 -IMPLICIT NONE - -! Input arguments. -INTEGER, INTENT(IN) :: D, N -REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) ! Rescaled on output. -INTEGER, INTENT(IN) :: M -REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) ! Rescaled on output. -! Output arguments. -INTEGER, INTENT(OUT) :: SIMPS(:,:) -REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) -INTEGER, INTENT(OUT) :: IERR(:) -! Optional arguments. -REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) -REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) -REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP -REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) -INTEGER, INTENT(IN), OPTIONAL :: IBUDGET, PMODE -LOGICAL, INTENT(IN), OPTIONAL :: CHAIN -LOGICAL, INTENT(IN), OPTIONAL :: EXACT - -! Local copies of optional input arguments. -REAL(KIND=R8) :: EPSL, EXTRAPL -INTEGER :: IBUDGETL -LOGICAL :: CHAINL, EXACTL, PLVL1, PLVL2 - -! Local variables. -LOGICAL :: PTINSIMP ! Tells if Q(:,MI) is in SIMPS(:,MI). -INTEGER :: I, J, K ! Loop iteration variables. -INTEGER :: IEXTRAPS ! Extrapolation budget. -INTEGER :: IERR_PRIV ! Private copy of the error flag. -INTEGER :: ITMP, JTMP ! Temporary variables for swapping, looping, etc. -INTEGER :: LWORK ! Size of the work array. -INTEGER :: MI ! Index of current interpolation point. -INTEGER :: VERTEX_PRIV ! Private copy of next vertex to add. -REAL(KIND=R8) :: CURRRAD ! Radius of the current circumsphere. -REAL(KIND=R8) :: MINRAD ! Minimum circumsphere radius observed. -REAL(KIND=R8) :: MINRAD_PRIV ! Private copy of MINRAD. -REAL(KIND=R8) :: PTS_DIAM ! Scaled diameter of data set. -REAL(KIND=R8) :: PTS_SCALE ! Data scaling factor. -REAL(KIND=R8) :: RNORML ! Euclidean norm of the projection residual. -REAL(KIND=R8) :: SIDE1, SIDE2 ! Signs (+/-1) denoting sides of a facet. - -! Local arrays, requiring O(d^2) additional memory. -INTEGER :: IPIV(D) ! Pivot indices. -INTEGER :: SEED(D+1) ! Copy of the SEED simplex. Only used if CHAIN = .TRUE. -REAL(KIND=R8) :: AT(D,D) ! The transpose of A, the linear coefficient matrix. -REAL(KIND=R8) :: B(D) ! The RHS of a linear system. -REAL(KIND=R8) :: CENTER(D) ! The circumcenter of a simplex. -REAL(KIND=R8) :: CENTER_PRIV(D) ! Private copy of CENTER. -REAL(KIND=R8) :: LQ(D,D) ! Holds LU or QR factorization of AT. -REAL(KIND=R8) :: PLANE(D+1) ! The hyperplane containing a facet. -REAL(KIND=R8) :: PRGOPT_DWNNLS(1) ! Options array for DWNNLS. -REAL(KIND=R8) :: PROJ(D) ! The projection of the current iterate. -REAL(KIND=R8) :: TAU(D) ! Householder reflector constants. -REAL(KIND=R8) :: X(D) ! The solution to a linear system. - -! Extrapolation work arrays are only allocated if DWNNLS is called. -INTEGER, ALLOCATABLE :: IWORK_DWNNLS(:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: W_DWNNLS(:,:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: WORK(:) ! Allocated with size LWORK. -REAL(KIND=R8), ALLOCATABLE :: WORK_DWNNLS(:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: X_DWNNLS(:) ! Only for DWNNLS. - -! External functions and subroutines. -REAL(KIND=R8), EXTERNAL :: DDOT ! Inner product (BLAS). -REAL(KIND=R8), EXTERNAL :: DNRM2 ! Euclidean norm (BLAS). -EXTERNAL :: DGEMV ! General matrix vector multiply (BLAS) -EXTERNAL :: DGEQP3 ! Perform a QR factorization with column pivoting (LAPACK). -EXTERNAL :: DGETRF ! Perform a LU factorization with partial pivoting (LAPACK). -EXTERNAL :: DGETRS ! Use the output of DGETRF to solve a linear system (LAPACK). -EXTERNAL :: DORMQR ! Apply householder reflectors to a matrix (LAPACK). -EXTERNAL :: DTRSM ! Perform a triangular solve (BLAS). -EXTERNAL :: DWNNLS ! Solve an inequality constrained least squares problem - ! (SLATEC). - -! Check for input size and dimension errors. -IF (D < 1) THEN ! The dimension must satisfy D > 0. - IERR(:) = 10; RETURN; END IF -IF (N < D+1) THEN ! Must have at least D+1 data points. - IERR(:) = 11; RETURN; END IF -IF (M < 1) THEN ! Must have at least one interpolation point. - IERR(:) = 12; RETURN; END IF -IF (SIZE(PTS,1) .NE. D) THEN ! Dimension of PTS array should match. - IERR(:) = 13; RETURN; END IF -IF (SIZE(PTS,2) .NE. N) THEN ! Number of data points should match. - IERR(:) = 14; RETURN; END IF -IF (SIZE(Q,1) .NE. D) THEN ! Dimension of Q should match. - IERR(:) = 15; RETURN; END IF -IF (SIZE(Q,2) .NE. M) THEN ! Number of interpolation points should match. - IERR(:) = 16; RETURN; END IF -IF (SIZE(SIMPS,1) .NE. D+1) THEN ! Need space for D+1 vertices per simplex. - IERR(:) = 17; RETURN; END IF -IF (SIZE(SIMPS,2) .NE. M) THEN ! There will be M output simplices. - IERR(:) = 18; RETURN; END IF -IF (SIZE(WEIGHTS,1) .NE. D+1) THEN ! There will be D+1 weights per simplex. - IERR(:) = 19; RETURN; END IF -IF (SIZE(WEIGHTS,2) .NE. M) THEN ! One vector of weights per simplex. - IERR(:) = 20; RETURN; END IF -IF (SIZE(IERR) .NE. M) THEN ! An error flag for each interpolation point. - IERR(:) = 21; RETURN; END IF - -! Check for optional arguments. -IF (PRESENT(INTERP_IN) .NEQV. PRESENT(INTERP_OUT)) THEN - IERR(:) = 22; RETURN; END IF -IF (PRESENT(INTERP_IN)) THEN ! Sizes must agree. - IF (SIZE(INTERP_IN,1) .NE. SIZE(INTERP_OUT,1)) THEN - IERR(:) = 23 ; RETURN; END IF - IF(SIZE(INTERP_IN,2) .NE. N) THEN - IERR(:) = 24; RETURN; END IF - IF (SIZE(INTERP_OUT,2) .NE. M) THEN - IERR(:) = 25; RETURN; END IF - INTERP_OUT(:,:) = 0.0_R8 ! Initialize output to zeros. -END IF -EPSL = SQRT(EPSILON(0.0_R8)) ! Get the machine unit roundoff constant. -IF (PRESENT(EPS)) THEN - IF (EPSL < EPS) THEN ! If the given precision is too small, ignore it. - EPSL = EPS - END IF -END IF -IF (PRESENT(IBUDGET)) THEN - IBUDGETL = IBUDGET ! Use the given budget if present. - IF (IBUDGETL < 1) THEN - IERR(:) = 26; RETURN; END IF -ELSE - IBUDGETL = 50000 ! Default value for budget. -END IF -IF (PRESENT(EXTRAP)) THEN - EXTRAPL = EXTRAP - IF (EXTRAPL < 0) THEN ! Check that the extrapolation distance is legal. - IERR(:) = 27; RETURN; END IF -ELSE - EXTRAPL = 0.1_R8 ! Default extrapolation distance (for normalized points). -END IF -IF (PRESENT(RNORM)) THEN - IF (SIZE(RNORM,1) .NE. M) THEN ! The length of the array must match. - IERR(:) = 28; RETURN; END IF - RNORM(:) = 0.0_R8 ! Initialize output to zeros. -END IF -IF (PRESENT(CHAIN)) THEN - CHAINL = CHAIN ! Turn chaining on, if necessarry. - SEED(:) = 0 ! Initialize SEED in case it is needed. -ELSE - CHAINL = .FALSE. -END IF -IF (PRESENT(EXACT)) THEN - EXACTL = EXACT ! Set error checking and exact diameter computations. -ELSE - EXACTL = .TRUE. -END IF -! Set the PMODE. -PLVL1 = .FALSE. -PLVL2 = .FALSE. -IF (PRESENT(PMODE)) THEN ! Check PMODE for legal values. - IF (PMODE .EQ. 1) THEN - PLVL1 = .TRUE. - ELSE IF (PMODE .EQ. 2) THEN - PLVL2 = .TRUE. - ELSE IF (PMODE .EQ. 3) THEN - PLVL1 = .TRUE.; PLVL2 = .TRUE. - ELSE - IERR(:) = 90; RETURN - END IF -ELSE ! The default setting for PMODE is level 1 parallelism if M > 1. - IF (M > 1) THEN - PLVL1 = .TRUE. - ELSE - PLVL2 = .TRUE. - END IF -END IF - -! Scale and center the data points and interpolation points. -CALL RESCALE(MINRAD, PTS_DIAM, PTS_SCALE) -IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. - IERR(:) = 30; RETURN; END IF - -! Query DGEQP3 for optimal work array size (LWORK). -LWORK = -1 -CALL DGEQP3(D,D,LQ,D,IPIV,TAU,B,LWORK,IERR(1)) -LWORK = INT(B(1)) ! Compute the optimal work array size. -ALLOCATE(WORK(LWORK), STAT=I) ! Allocate WORK to size LWORK. -IF (I .NE. 0) THEN ! Check for memory allocation errors. - IERR(:) = 50; RETURN; END IF - -! Initialize PRGOPT_DWNNLS in case of extrapolation. -PRGOPT_DWNNLS(1) = 1.0_R8 - -! Initialize all error codes to "TBD" values. -IERR(:) = 40 - -! Begin level 1 parallel region (over all interpolation points in Q). -!$OMP PARALLEL & -! -! The FIRSTPRIVATE list specifies initialized variables, of which each -! thread has a private copy. -!$OMP& FIRSTPRIVATE(SEED), & -! -! The PRIVATE list specifies uninitialized variables, of which each -! thread has a private copy. -!$OMP& PRIVATE(I, J, K, IEXTRAPS, ITMP, JTMP, CURRRAD, MI, MINRAD, & -!$OMP& RNORML, SIDE1, SIDE2, IERR_PRIV, VERTEX_PRIV, MINRAD_PRIV, & -!$OMP& PTINSIMP, IPIV, AT, B, CENTER, CENTER_PRIV, LQ, PLANE, & -!$OMP& PROJ, TAU, WORK, X, IWORK_DWNNLS, W_DWNNLS, WORK_DWNNLS, & -!$OMP& X_DWNNLS), & -! -! Any variables not explicitly listed above receive the SHARED scope -! by default and are visible across all threads. -!$OMP& DEFAULT(SHARED), & -! -!$OMP& IF(PLVL1) -!$OMP DO SCHEDULE(DYNAMIC) -OUTER : DO MI = 1, M - !$OMP CRITICAL(CHECK_IERR) - ! Check if this interpolation point was already found. - IF (IERR(MI) .EQ. 40) THEN - IERR(MI) = 0 - IERR_PRIV = 0 - ELSE - IERR_PRIV = -1 - END IF - !$OMP END CRITICAL(CHECK_IERR) - IF(IERR_PRIV .EQ. -1) CYCLE OUTER - - ! Initialize the projection and reset the residual. - PROJ(:) = Q(:,MI) - RNORML = 0.0_R8 - - ! Check if extrapolation is enabled. - IF (EXTRAPL < EPSL) THEN - IEXTRAPS = -1 ! If not, set the extrapolation budget negative. - ELSE - IEXTRAPS = 1 ! Allow for exactly one projection for this point. - END IF - - ! If there is no useable seed or if chaining is turned off, then make a new - ! simplex. - IF( (.NOT. CHAINL) .OR. SEED(1) .EQ. 0) THEN -! CALL MAKEFIRSTSIMP(); IF(IERR_PRIV .NE. 0) CYCLE OUTER - - -!****************************************************************************** -! Due to OpenMP's handling of variable scope, the parallel implementation of -! the subroutine MAKEFIRSTSIMP() has been in-lined here. -! -! SUBROUTINE MAKEFIRSTSIMP() -! -! Iteratively construct the first simplex by choosing points that -! minimize the radius of the smallest circumball. Let P_1, P_2, ..., P_K -! denote the current list of vertices for the simplex. Let P* denote the -! candidate vertex to be added to the simplex. Let CENTER denote the -! circumcenter of the simplex. Then -! -! X = CENTER - P_1 -! -! is given by the minimum norm solution to the underdetermined linear system -! -! A X = B, where -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_K - P_1, P* - P_1 ] and -! B = [ /2, /2, ..., /2 ]^T. -! -! Then the radius of the smallest circumsphere is CURRRAD = \| X \|, -! and the next vertex is given by P_{K+1} = argmin_{P*} CURRRAD, where P* -! ranges over points in PTS that are not already a vertex of the simplex. -! -! On output, this subroutine fully populates the matrix A^T and vector B, -! and fills SIMPS(:,MI) with the indices of a valid Delaunay simplex. - -! Initialize simplex and shared variables. -SIMPS(:,MI) = 0 -MINRAD_PRIV = HUGE(0.0_R8) -MINRAD = HUGE(0.0_R8) - -! Below is a Level 2 parallel region over N points in PTS to find the -! first and second vertices SIMPS(1,MI) and SIMPS(2,MI). -!$OMP PARALLEL & -! -! The FIRSTPRIVATE list specifies initialized variables, of which each -! thread has a private copy. -!$OMP& FIRSTPRIVATE(MINRAD_PRIV), & -! -! The PRIVATE list specifies uninitialized variables, of which each -! thread has a private copy. -!$OMP& PRIVATE(I, CURRRAD, VERTEX_PRIV), & -! -! Any variables not explicitly listed above receive the SHARED scope -! by default and are visible across all threads. -!$OMP& DEFAULT(SHARED), & -! -!$OMP& IF(PLVL2) -! Find the first point, i.e., the closest point to Q(:,MI). -!$OMP DO SCHEDULE(STATIC) -DO I = 1, N - ! Check the distance to Q(:,MI) - CURRRAD = DNRM2(D, PTS(:,I) - PROJ(:), 1) - IF (CURRRAD < MINRAD_PRIV) THEN - MINRAD_PRIV = CURRRAD; VERTEX_PRIV = I; - END IF -END DO -!$OMP END DO -!$OMP CRITICAL(REDUC_1) -IF (MINRAD_PRIV < MINRAD) THEN - MINRAD = MINRAD_PRIV; SIMPS(1,MI) = VERTEX_PRIV; -END IF -!$OMP END CRITICAL(REDUC_1) -! Find the second point, i.e., the closest point to PTS(:,SIMPS(1,MI)). -MINRAD_PRIV = HUGE(0.0_R8) -!$OMP BARRIER -!$OMP SINGLE -MINRAD = HUGE(0.0_R8) -!$OMP END SINGLE -!$OMP DO SCHEDULE(STATIC) -DO I = 1, N - ! Skip repeated vertices. - IF (I .EQ. SIMPS(1,MI)) CYCLE - ! Check the diameter of the resulting circumsphere. - CURRRAD = DNRM2(D, PTS(:,I)-PTS(:,SIMPS(1,MI)), 1) - IF (CURRRAD < MINRAD_PRIV) THEN - MINRAD_PRIV = CURRRAD; VERTEX_PRIV = I - END IF -END DO -!$OMP END DO -!$OMP CRITICAL(REDUC_2) -IF (MINRAD_PRIV < MINRAD) THEN - MINRAD = MINRAD_PRIV; SIMPS(2,MI) = VERTEX_PRIV -END IF -!$OMP END CRITICAL(REDUC_2) -!$OMP END PARALLEL -! This is the end of the Level 2 parallel block. -IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. - IERR(MI) = 30; CYCLE OUTER; END IF - -! Set up the first row of the system A X = B. -AT(:,1) = PTS(:,SIMPS(2,MI)) - PTS(:,SIMPS(1,MI)) -B(1) = DDOT(D, AT(:,1), 1, AT(:,1), 1) / 2.0_R8 - -! Loop to collect the remaining D-1 vertices for the first simplex. -DO I = 2, D - ! Compute A^T P = Q R for the current matrix A^T. - LQ(:,1:I-1) = AT(:,1:I-1) - CALL DGEQP3(D, I-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 80 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Set the RHS to P^T B. - FORALL (ITMP = 1:I-1) X(ITMP) = B(IPIV(ITMP)) - ! Solve R^T Q^T X = P^T B for Q^T X, and save for later. - CALL DTRSM('L', 'U', 'T', 'N', I-1, 1, 1.0_R8, LQ, D, X, D) - ! Make a copy for computing the current center. - CENTER(1:I-1) = X(1:I-1) - CENTER(I:D) = 0.0_R8 - ! Apply Q from the left. - CALL DORMQR('L', 'N', D, 1, I-1, LQ, D, TAU, CENTER, D, WORK, & - LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 83 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - CENTER = CENTER + PTS(:,SIMPS(1,MI)) - ! Re-initialize the radius for each iteration. - MINRAD = HUGE(0.0_R8) - MINRAD_PRIV = HUGE(0.0_R8) - VERTEX_PRIV = 0 - - ! This is another Level 2 parallel block over N points in PTS. - !$OMP PARALLEL & - ! - ! The FIRSTPRIVATE list specifies initialized variables, of which each - ! thread has a private copy. - !$OMP& FIRSTPRIVATE(LQ, MINRAD_PRIV, VERTEX_PRIV, X), & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(J, CURRRAD, WORK), & - ! - ! The REDUCTION clause specifies a PRIVATE variable that will retain - ! some value (i.e., max, min, sum, etc.) upon output. - !$OMP& REDUCTION(MAX:IERR_PRIV), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& IF(PLVL2) - - ! Initialize the error flag. - IERR_PRIV = 0 - !$OMP DO SCHEDULE(STATIC) - DO J = 1, N - IF (IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. - ! Check that this point is not already in the simplex. - IF (ANY(SIMPS(:,MI) .EQ. J)) CYCLE - ! If PTS(:,J) is more than twice MINRAD_PRIV from CENTER, do a quick skip. - IF (DNRM2(D, CENTER - PTS(:,J), 1) > 2.0_R8 * MINRAD_PRIV) CYCLE - ! Perform a rank-1 update to the current QR factorization of A^T by - ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the - ! final column of R. - LQ(:,I) = PTS(:,J) - PTS(:,SIMPS(1,MI)) - CALL DORMQR('L', 'T', D, 1, I-1, LQ(:,1:I-1), D, TAU, LQ(:,I), D, & - WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - IERR_PRIV = 83; CYCLE - END IF - ! Implicitly apply the next Householder reflector. - LQ(I,I) = DNRM2(D+1-I, LQ(I:D,I), 1) - IF (LQ(I,I) < EPSL) THEN ! A is rank-deficient. - CYCLE ! If rank-deficient, skip this point. - END IF - ! Update the current radius by \| Q^T X \| = \| X \|. - WORK(1:I-1) = (LQ(1:I-1,I) / 2.0_R8) - X(1:I-1) - WORK(I) = LQ(I,I) / 2.0_R8 - X(I) = DDOT(I, LQ(1:I,I), 1, WORK(1:I), 1) / LQ(I,I) - CURRRAD = DNRM2(I, X(1:I), 1) - ! Compare the last component of Q^T X to the current minimum. - IF (CURRRAD < MINRAD_PRIV) THEN - MINRAD_PRIV = CURRRAD; VERTEX_PRIV = J - END IF - END DO - !$OMP END DO - !$OMP CRITICAL(REDUC_3) - IF (MINRAD_PRIV < MINRAD) THEN - MINRAD = MINRAD_PRIV; SIMPS(I+1,MI) = VERTEX_PRIV - END IF - !$OMP END CRITICAL(REDUC_3) - !$OMP END PARALLEL - ! End of Level 2 parallel block. - - ! Check the final error flag. - IF (IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = IERR_PRIV - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Check that a point was found. If not, then all the points must lie in a - ! lower dimensional linear manifold (error case). - IF (SIMPS(I+1,MI) .EQ. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 31 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! If all operations were successful, add the best P* to the linear system. - AT(:,I) = PTS(:,SIMPS(I+1,MI)) - PTS(:,SIMPS(1,MI)) - B(I) = DDOT(D, AT(:,I), 1, AT(:,I), 1) / 2.0_R8 -END DO -! RETURN -! END SUBROUTINE MAKEFIRSTSIMP -! This marks the end of the in-lined MAKEFIRSTSIMP() subroutine call. -!****************************************************************************** - - - ! Otherwise, use the seed. - ELSE - ! Copy the seed to the current simplex. - SIMPS(:,MI) = SEED(:) - ! Rebuild the linear system. - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - - ! Inner loop searching for a simplex containing the point Q(:,MI). - INNER : DO K = 1, IBUDGETL - - ! If chaining is on, save each good simplex as the next seed. - IF (CHAINL) SEED(:) = SIMPS(:,MI) - - -!****************************************************************************** -! Due to OpenMP's handling of variable scope, the parallel implementation of -! the subroutine PTINSIMP() has been in-lined here. -! -! FUNCTION PTINSIMP() RESULT(TF) -! Determine if any interpolation points are in the current simplex, whose -! vertices (P_1, P_2, ..., P_{D+1}) are indexed by SIMPS(:,MI). These -! vertices determine a positive cone with generators V_I = P_{I+1} - P_1, -! I = 1, ..., D. For each interpolation point Q* in Q, Q* - P_1 can be -! expressed as a unique linear combination of the V_I. If all these linear -! weights are nonnegative and sum to less than or equal to 1.0, then Q* is -! in the simplex with vertices {P_I}_{I=1}^{D+1}. -! -! If any interpolation points in Q are contained in the simplex whose -! vertices are indexed by SIMPS(:,MI), then those points are marked as solved -! and the values of SIMPS and WEIGHTS are updated appropriately. On output, -! WEIGHTS(:,MI) contains the affine weights for producing Q(:,MI) as an -! affine combination of the points in PTS indexed by SIMPS(:,MI). If these -! weights are nonnegative, then PTINSIMP() returns TRUE. - -! Initialize the return value and local variables. -PTINSIMP = .FALSE. - -! Compute the LU factorization of the matrix A^T, whose columns are -! P_{I+1} - P_1. -LQ = AT -CALL DGETRF(D, D, LQ, D, IPIV, IERR_PRIV) -IF (IERR_PRIV < 0) THEN ! LAPACK illegal input. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 81 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER -ELSE IF (IERR_PRIV > 0) THEN ! Rank-deficiency detected. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 61 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER -END IF -! Solve A^T w = WORK to get the affine weights for Q(:,MI) or its projection. -WORK(1:D) = PROJ(:) - PTS(:,SIMPS(1,MI)) -CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(1:D), D, IERR_PRIV) -IF (IERR_PRIV < 0) THEN ! LAPACK illegal input. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 82 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER -END IF -WEIGHTS(2:D+1,MI) = WORK(1:D) -WEIGHTS(1,MI) = 1.0_R8 - SUM(WEIGHTS(2:D+1,MI)) -! Check if the weights for Q(:,MI) are nonnegative. -IF (ALL(WEIGHTS(:,MI) .GE. -EPSL)) PTINSIMP = .TRUE. - -! If Level 1 parallelism is active, do not parallelize this loop. -IF (PLVL1) THEN - ! Loop over all remaining unsolved interoplation points. Uses PLANE(:) - ! as a work array. - DO I = MI+1, M - ! Check that no solution has already been found. - !$OMP CRITICAL(CHECK_IERR) - ITMP = IERR(I) - !$OMP END CRITICAL(CHECK_IERR) - IF (ITMP .NE. 40) CYCLE - ! Solve A^T w = PLANE to get the affine weights for Q(:,I). - PLANE(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) - CALL DGETRS('N', D, 1, LQ, D, IPIV, PLANE(2:D+1), D, ITMP) - IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. - ! Check if the weights define a convex combination. - PLANE(1) = 1.0_R8 - SUM(PLANE(2:D+1)) - IF (ALL(PLANE(1:D+1) .GE. -EPSL)) THEN - !$OMP CRITICAL(CHECK_IERR) - IF(IERR(I) .EQ. 40) THEN - ! Copy the simplex indices and weights then flag as complete. - SIMPS(:,I) = SIMPS(:,MI) - WEIGHTS(:,I) = PLANE(1:D+1) - IERR(I) = 0 - END IF - !$OMP END CRITICAL(CHECK_IERR) - END IF - END DO -! If Level 1 parallelism is not active, there will be no conflicts for -! parallelizing this loop. -ELSE - ! Level 2 parallel block over all remaining unsolved interoplation - ! points. Uses PLANE(:) as a work array. - !$OMP PARALLEL DO & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(I, PLANE, ITMP), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& SCHEDULE(STATIC), & - !$OMP& IF(PLVL2) - DO I = MI+1, M - ! Check that no solution has already been found. - IF (IERR(I) .NE. 40) CYCLE - ! Solve A^T w = PLANE to get the affine weights for Q(:,I). - PLANE(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) - CALL DGETRS('N', D, 1, LQ, D, IPIV, PLANE(2:D+1), D, ITMP) - IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. - ! Check if the weights define a convex combination. - PLANE(1) = 1.0_R8 - SUM(PLANE(2:D+1)) - IF (ALL(PLANE(1:D+1) .GE. -EPSL)) THEN - ! Copy the simplex indices and weights then flag as complete. - SIMPS(:,I) = SIMPS(:,MI) - WEIGHTS(:,I) = PLANE(1:D+1) - IERR(I) = 0 - END IF - END DO - !$OMP END PARALLEL DO -END IF -! End of Level 2 parallel block. -! RETURN -! END FUNCTION PTINSIMP -! This marks the end of the in-lined PTINSIMP() subroutine call. -!****************************************************************************** - - - ! Check if the current simplex contains Q(:,MI). - IF (PTINSIMP) EXIT INNER - - ! Swap out the least weighted vertex, but save its value in case it - ! needs to be restored later. - JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) - ITMP = SIMPS(JTMP,MI) - SIMPS(JTMP,MI) = SIMPS(D+1,MI) - - ! If the least weighted vertex (index JTMP) is not the first vertex, - ! then just drop row (JTMP-1) from the linear system (corresponding - ! to column (JTMP-1) of A^T). - IF(JTMP .NE. 1) THEN - AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) - ! However, if JTMP = 1, then both A^T and B must be reconstructed. - ELSE - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - - ! Compute the next simplex (do one flip). -! CALL MAKESIMPLEX(); IF (IERR_PRIV .NE. 0) CYCLE OUTER - - -!****************************************************************************** -! Due to OpenMP's handling of variable scope, the parallel implementation of -! the subroutine MAKESIMPLEX() has been in-lined here. -! -! SUBROUTINE MAKESIMPLEX() -! Given a Delaunay facet F whose containing hyperplane does not contain -! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' -! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F -! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the -! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly -! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing -! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices -! P_1, P_2, ..., P_D, P*. Then -! -! X = CENTER - P_1 -! -! is given by the solution to the nonsingular linear system -! -! A X = B where -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and -! B = [ /2, /2, ..., /2 ]^T. -! -! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the -! candidate P* that satisfies both of the following: -! -! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) -! must be on the same side of PLANE. -! -! 2) The circumball about CENTER must not contain any points in PTS in its -! interior (Delaunay property). -! -! The above are necessary and sufficient conditions for flipping the -! Delaunay simplex, given that F is indeed a Delaunay facet. -! -! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices -! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex -! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and -! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were -! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an -! extrapolation point (not a convex combination of points in PTS). - -! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed -! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. -! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal -! vector is any nonzero vector in ker A, where the matrix -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. -! -! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR -! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. -! Then the last column of Q is orthogonal to the range of A^T, and in ker A. -IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. - ! Compute the QR factorization. - IPIV=0 - LQ = AT - CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 80 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! The nullspace is given by the last column of Q. - PLANE(1:D-1) = 0.0_R8 - PLANE(D) = 1.0_R8 - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & - LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 83 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Calculate the constant \alpha defining the plane. - PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) - ! Compute the sign for the side of PLANE containing Q(:,MI). - SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) - SIDE1 = SIGN(1.0_R8,SIDE1) - - ! Set the RHS to P^T B. - FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) - ! Solve R^T Q^T X = P^T B for Q^T X. - CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) - - ! Initialize the center, radius, simplex, and OpenMP variabls. - SIMPS(D+1,MI) = 0 - CENTER(:) = 0.0_R8 - CENTER_PRIV(:) = 0.0_R8 - MINRAD = HUGE(0.0_R8) - MINRAD_PRIV = HUGE(0.0_R8) - VERTEX_PRIV = 0 - - ! Begin Level 2 parallel loop over N points in PTS. - !$OMP PARALLEL & - ! - ! The FIRSTPRIVATE list specifies initialized variables, of which each - ! thread has a private copy. - !$OMP& FIRSTPRIVATE(CENTER_PRIV, LQ, MINRAD_PRIV, VERTEX_PRIV), & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(I, SIDE2, WORK), & - ! - ! The REDUCTION clause specifies a PRIVATE variable that will retain - ! some value (i.e., max, min, sum, etc.) upon output. - !$OMP& REDUCTION(MAX:IERR_PRIV), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& IF(PLVL2) - - ! Initialize the error flag. - IERR_PRIV = 0 - !$OMP DO SCHEDULE(STATIC) - DO I = 1, N - IF(IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. - ! Check that P* is inside the current ball. - IF (DNRM2(D, PTS(:,I) - CENTER_PRIV(:), 1) > MINRAD_PRIV) CYCLE - ! Check that P* is on the appropriate halfspace. - SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) - IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE - ! Perform a rank-1 update to the current QR factorization of A^T by - ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the - ! final column of R. - LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) - CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & - LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - IERR_PRIV = 83; CYCLE - END IF - ! Update the last element of Q^T X. - WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) - WORK(D) = LQ(D,D) / 2.0_R8 - CENTER_PRIV(1:D-1) = X(1:D-1) - CENTER_PRIV(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) - ! Get the center by applying Q to the solution. - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER_PRIV, D, & - WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - IERR_PRIV = 83; CYCLE - END IF - ! Update the new radius, center, and simplex. - MINRAD_PRIV = DNRM2(D, CENTER_PRIV, 1) - CENTER_PRIV(:) = CENTER_PRIV(:) + PTS(:,SIMPS(1,MI)) - VERTEX_PRIV = I - END DO - !$OMP END DO - !$OMP CRITICAL(REDUC_4) - ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. - IF (VERTEX_PRIV .NE. 0) THEN - IF (DNRM2(D, PTS(:,VERTEX_PRIV) - CENTER(:), 1) < MINRAD) THEN - MINRAD = MINRAD_PRIV - CENTER(:) = CENTER_PRIV(:) - SIMPS(D+1,MI) = VERTEX_PRIV - END IF - END IF - !$OMP END CRITICAL(REDUC_4) - !$OMP END PARALLEL - ! End level 2 parallel region. - - ! Check for error flags. - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = IERR_PRIV - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Check for extrapolation condition. - IF(SIMPS(D+1,MI) .NE. 0) THEN - ! Add new point to the linear system. - AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - END IF -ELSE ! Special case where D=1. - PLANE(1) = 1.0_R8 - PLANE(2) = PTS(1,SIMPS(1,MI)) - SIDE1 = SIGN(1.0_R8, PROJ(1) - PLANE(2)) - ! Initialize the radius, simplex, and OpenMP variabls. - SIMPS(2,MI) = 0 - MINRAD = HUGE(0.0_R8) - MINRAD_PRIV = HUGE(0.0_R8) - VERTEX_PRIV = 0 - ! Begin Level 2 parallel loop over N points in PTS. - !$OMP PARALLEL & - ! - ! The FIRSTPRIVATE list specifies initialized variables, of which each - ! thread has a private copy. - !$OMP& FIRSTPRIVATE(MINRAD_PRIV, VERTEX_PRIV), & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(I, SIDE2), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& IF(PLVL2) - - !$OMP DO SCHEDULE(STATIC) - DO I = 1, N - ! Check that P* is on the appropriate halfspace. - SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 - IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE - ! Check that P* is closer than the current solution. - IF (SIDE2 > MINRAD) CYCLE - ! Update the minimum distance and save the index I. - MINRAD_PRIV = SIDE2 - VERTEX_PRIV = I - END DO - !$OMP END DO - !$OMP CRITICAL(REDUC_4) - ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. - IF (VERTEX_PRIV .NE. 0) THEN - IF (MINRAD_PRIV < MINRAD) THEN - MINRAD = MINRAD_PRIV - SIMPS(2,MI) = VERTEX_PRIV - END IF - END IF - !$OMP END CRITICAL(REDUC_4) - !$OMP END PARALLEL - ! Check for extrapolation condition. - IF(SIMPS(2,MI) .NE. 0) THEN - ! Add new point to the linear system. - AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) - B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 - END IF -END IF -! RETURN -! END SUBROUTINE MAKESIMPLEX -! End of in-lined code for MAKESIMPLEX(). -!****************************************************************************** - - - ! If no vertex was found, then this is an extrapolation point. - IF (SIMPS(D+1,MI) .EQ. 0) THEN - ! If extrapolation is not allowed (EXTRAP=0), do not proceed. - IF (IEXTRAPS < 0) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! Set the error flag and skip this point. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 2 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - - ! If extrapolation is allowed (EXTRAP>0), check the budget. - ELSE IF (IEXTRAPS .EQ. 0) THEN - ! A second projection has been attempted. This code is rarely - ! called, except in extreme cases involving nearly singular - ! simplices near the convex hull of P. - - ! Swap the weights to match the simplex indices, and zero the - ! most negative weight. - !$OMP CRITICAL(CHECK_IERR) - WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) - WEIGHTS(D+1,MI) = 0.0_R8 - !$OMP END CRITICAL(CHECK_IERR) - ! Loop through all the remaining facets from which Q(:,MI) is - ! visible, and attempt to flip across each one. - DO WHILE (SIMPS(D+1,MI) .EQ. 0) - ! Restore the previous simplex and linear system. - SIMPS(D+1,MI) = ITMP - AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - ! Find the next most negative weight. - JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) - ! Check if WEIGHTS(JTMP,MI) .GE. 0. - IF (WEIGHTS(JTMP,MI) .GE. -EPSL) THEN - ! There is no other direction to flip, so Q(:,MI) must be - ! within EPSL of the current simplex. - ! Project Q(:,MI) onto the current simplex. - - ! Since at least one projection has already been done, - ! the work arrays have already been allocated. - PRGOPT_DWNNLS(1) = 1.0_R8 - IWORK_DWNNLS(1) = 6*D + 6 - IWORK_DWNNLS(2) = 2*D + 2 - ! Set equality constraint. - W_DWNNLS(1,1:D+2) = 1.0_R8 - ! Populate LS coefficient matrix and RHS. - FORALL (I=1:D+1) W_DWNNLS(2:D+1,I) = PTS(:,SIMPS(I,MI)) - W_DWNNLS(2:D+1,D+2) = PROJ(:) - ! Project onto the current simplex. - CALL DWNNLS(W_DWNNLS, D+1, 1, D, D+1, 0, PRGOPT_DWNNLS, & - WEIGHTS(:,MI), WORK(1), IERR_PRIV, IWORK_DWNNLS, & - WORK_DWNNLS) - IF (IERR_PRIV .EQ. 1) THEN ! Failure to converge. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 71 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - ELSE IF (IERR_PRIV .EQ. 2) THEN ! Illegal input detected. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 72 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! A solution has been found; return it. - EXIT INNER - END IF - ! Otherwise, swap the vertices. - ITMP = SIMPS(JTMP,MI) - SIMPS(JTMP,MI) = SIMPS(D+1,MI) - ! Swap the weights to match, and zero the most negative weight. - !$OMP CRITICAL(CHECK_IERR) - WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) - WEIGHTS(D+1,MI) = 0.0_R8 - !$OMP END CRITICAL(CHECK_IERR) - ! If the least weighted vertex (index JTMP) is not the first vertex, - ! then just drop row (JTMP-1) from the linear system - ! (corresponding to the JTMP-1st column of A^T). - IF (JTMP .NE. 1) THEN - AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) - ! However, if JTMP=1, then both A^T and B must be reconstructed. - ELSE - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - ! Compute another simplex (try to flip again). -! CALL MAKESIMPLEX(); IF (IERR(MI) .NE. 0) CYCLE OUTER - - -!****************************************************************************** -! Due to OpenMP's handling of variable scope, the parallel implementation of -! the subroutine MAKESIMPLEX() has been in-lined here. -! -! SUBROUTINE MAKESIMPLEX() -! Given a Delaunay facet F whose containing hyperplane does not contain -! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' -! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F -! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the -! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly -! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing -! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices -! P_1, P_2, ..., P_D, P*. Then -! -! X = CENTER - P_1 -! -! is given by the solution to the nonsingular linear system -! -! A X = B where -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and -! B = [ /2, /2, ..., /2 ]^T. -! -! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the -! candidate P* that satisfies both of the following: -! -! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) -! must be on the same side of PLANE. -! -! 2) The circumball about CENTER must not contain any points in PTS in its -! interior (Delaunay property). -! -! The above are necessary and sufficient conditions for flipping the -! Delaunay simplex, given that F is indeed a Delaunay facet. -! -! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices -! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex -! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and -! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were -! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an -! extrapolation point (not a convex combination of points in PTS). - -! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed -! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. -! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal -! vector is any nonzero vector in ker A, where the matrix -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. -! -! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR -! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. -! Then the last column of Q is orthogonal to the range of A^T, and in ker A. -IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. - ! Compute the QR factorization. - IPIV=0 - LQ = AT - CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 80 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! The nullspace is given by the last column of Q. - PLANE(1:D-1) = 0.0_R8 - PLANE(D) = 1.0_R8 - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & - LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 83 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Calculate the constant \alpha defining the plane. - PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) - ! Compute the sign for the side of PLANE containing Q(:,MI). - SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) - SIDE1 = SIGN(1.0_R8,SIDE1) - ! Set the RHS to P^T B. - FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) - ! Solve R^T Q^T X = P^T B for Q^T X. - CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) - ! Initialize the center, radius, simplex, and OpenMP variabls. - SIMPS(D+1,MI) = 0 - CENTER(:) = 0.0_R8 - CENTER_PRIV(:) = 0.0_R8 - MINRAD = HUGE(0.0_R8) - MINRAD_PRIV = HUGE(0.0_R8) - VERTEX_PRIV = 0 - - ! Begin Level 2 parallel loop over N points in PTS. - !$OMP PARALLEL & - ! - ! The FIRSTPRIVATE list specifies initialized variables, of which each - ! thread has a private copy. - !$OMP& FIRSTPRIVATE(CENTER_PRIV, LQ, MINRAD_PRIV, VERTEX_PRIV), & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(I, SIDE2, WORK), & - ! - ! The REDUCTION clause specifies a PRIVATE variable that will retain - ! some value (i.e., max, min, sum, etc.) upon output. - !$OMP& REDUCTION(MAX:IERR_PRIV), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& IF(PLVL2) - - ! Initialize the error flag. - IERR_PRIV = 0 - !$OMP DO SCHEDULE(STATIC) - DO I = 1, N - IF(IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. - ! Check that P* is inside the current ball. - IF (DNRM2(D, PTS(:,I) - CENTER_PRIV(:), 1) > MINRAD_PRIV) CYCLE - ! Check that P* is on the appropriate halfspace. - SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) - IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE - ! Perform a rank-1 update to the current QR factorization of A^T by - ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the - ! final column of R. - LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) - CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & - LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - IERR_PRIV = 83; CYCLE - END IF - ! Update the last element of Q^T X. - WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) - WORK(D) = LQ(D,D) / 2.0_R8 - CENTER_PRIV(1:D-1) = X(1:D-1) - CENTER_PRIV(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) - ! Get the center by applying Q to the solution. - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER_PRIV, D, & - WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - IERR_PRIV = 83; CYCLE - END IF - ! Update the new radius, center, and simplex. - MINRAD_PRIV = DNRM2(D, CENTER_PRIV, 1) - CENTER_PRIV(:) = CENTER_PRIV(:) + PTS(:,SIMPS(1,MI)) - VERTEX_PRIV = I - END DO - !$OMP END DO - !$OMP CRITICAL(REDUC_4) - ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. - IF (VERTEX_PRIV .NE. 0) THEN - IF (DNRM2(D, PTS(:,VERTEX_PRIV) - CENTER(:), 1) < MINRAD) THEN - MINRAD = MINRAD_PRIV - CENTER(:) = CENTER_PRIV(:) - SIMPS(D+1,MI) = VERTEX_PRIV - END IF - END IF - !$OMP END CRITICAL(REDUC_4) - !$OMP END PARALLEL - ! End level 2 parallel region. - - ! Check for error flags. - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = IERR_PRIV - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Check for extrapolation condition. - IF(SIMPS(D+1,MI) .NE. 0) THEN - ! Add new point to the linear system. - AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - END IF -ELSE ! Special case where D=1. - PLANE(1) = 1.0_R8 - PLANE(2) = PTS(1,SIMPS(1,MI)) - SIDE1 = SIGN(1.0_R8, PROJ(1) - PLANE(2)) - ! Initialize the radius, simplex, and OpenMP variabls. - SIMPS(2,MI) = 0 - MINRAD = HUGE(0.0_R8) - MINRAD_PRIV = HUGE(0.0_R8) - VERTEX_PRIV = 0 - ! Begin Level 2 parallel loop over N points in PTS. - !$OMP PARALLEL & - ! - ! The FIRSTPRIVATE list specifies initialized variables, of which each - ! thread has a private copy. - !$OMP& FIRSTPRIVATE(MINRAD_PRIV, VERTEX_PRIV), & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(I, SIDE2), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& IF(PLVL2) - - !$OMP DO SCHEDULE(STATIC) - DO I = 1, N - ! Check that P* is on the appropriate halfspace. - SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 - IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE - ! Check that P* is closer than the current solution. - IF (SIDE2 > MINRAD) CYCLE - ! Update the minimum distance and save the index I. - MINRAD_PRIV = SIDE2 - VERTEX_PRIV = I - END DO - !$OMP END DO - !$OMP CRITICAL(REDUC_4) - ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. - IF (VERTEX_PRIV .NE. 0) THEN - IF (MINRAD_PRIV < MINRAD) THEN - MINRAD = MINRAD_PRIV - SIMPS(2,MI) = VERTEX_PRIV - END IF - END IF - !$OMP END CRITICAL(REDUC_4) - !$OMP END PARALLEL - ! Check for extrapolation condition. - IF(SIMPS(2,MI) .NE. 0) THEN - ! Add new point to the linear system. - AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) - B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 - END IF -END IF -! RETURN -! END SUBROUTINE MAKESIMPLEX -! End of in-lined code for MAKESIMPLEX(). -!****************************************************************************** - - - END DO - ! If the loop terminates, then a good direction was found. - ! Resume the visibility walk as normal. - CYCLE INNER - END IF - - ! Otherwise, project the extrapolation point onto the convex hull. -! CALL PROJECT(); IF (IERR_PRIV .NE. 0) CYCLE OUTER - - -!****************************************************************************** -! Due to OpenMP's handling of variable scope, the parallel (identical to serial) -! implementation of the subroutine PROJECT() has been in-lined here. -! -! SUBROUTINE PROJECT() -! Project a point outside the convex hull of the point set onto the convex hull -! by solving an inequality constrained least squares problem. The solution to -! the least squares problem gives the projection as a convex combination of the -! data points. The projection can then be computed by performing a matrix -! vector multiplication. - -! Allocate work arrays. -IF (.NOT. ALLOCATED(IWORK_DWNNLS)) THEN - ALLOCATE(IWORK_DWNNLS(D+1+N), STAT=IERR_PRIV) - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 70 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF -END IF -IF (.NOT. ALLOCATED(WORK_DWNNLS)) THEN - ALLOCATE(WORK_DWNNLS(D+1+N*5), STAT=IERR_PRIV) - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 70 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF -END IF -IF (.NOT. ALLOCATED(W_DWNNLS)) THEN - ALLOCATE(W_DWNNLS(D+1,N+1), STAT=IERR_PRIV) - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 70 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF -END IF -IF (.NOT. ALLOCATED(X_DWNNLS)) THEN - ALLOCATE(X_DWNNLS(N), STAT=IERR_PRIV) - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 70 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF -END IF - -! Initialize work array and settings values. -IWORK_DWNNLS(1) = D+1+5*N -IWORK_DWNNLS(2) = D+1+N -W_DWNNLS(1, :) = 1.0_R8 ! Set convexity (equality) constraint. -W_DWNNLS(2:D+1,1:N) = PTS(:,:) ! Copy data points. -W_DWNNLS(2:D+1,N+1) = PROJ(:) ! Copy extrapolation point. -! Compute the solution to the inequality constrained least squares problem to -! get the projection coefficients. -CALL DWNNLS(W_DWNNLS, D+1, 1, D, N, 0, PRGOPT_DWNNLS, X_DWNNLS, RNORML, & - IERR_PRIV, IWORK_DWNNLS, WORK_DWNNLS) -IF (IERR_PRIV .EQ. 1) THEN ! Failure to converge. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 71 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER -ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 72 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER -END IF -! Compute the actual projection via matrix vector multiplication. -CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) -! Zero all weights that are approximately zero and renormalize the sum. -WHERE (X_DWNNLS < EPSL) X_DWNNLS = 0.0_R8 -X_DWNNLS(:) = X_DWNNLS(:) / SUM(X_DWNNLS) -! Compute the actual projection via matrix vector multiplication. -CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) -RNORML = DNRM2(D, PROJ(:) - Q(:,MI), 1) -! RETURN -! END SUBROUTINE PROJECT -! End of in-lined code for PROJECT(). -!****************************************************************************** - - - ! Check the value of RNORML for over-extrapolation. - IF (RNORML > EXTRAPL * PTS_DIAM) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! If present, record the unscaled RNORM output. - IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE - ! Set the error flag and skip this point. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 2 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - - ! Otherwise, restore the previous simplex and continue with the - ! projected value. - SIMPS(D+1,MI) = ITMP - AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - IEXTRAPS = IEXTRAPS - 1 ! Decrement the budget. - END IF - - ! End of inner loop for finding each interpolation point. - END DO INNER - - ! Check for budget violation conditions. - IF (K > IBUDGETL) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! Set the error flag and skip this point. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 60 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - - ! If the residual is nonzero, set the extrapolation flag. - IF (RNORML > EPSL) THEN - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 1 - !$OMP END CRITICAL(CHECK_IERR) - END IF - - ! If present, record the RNORM output. - IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE - -END DO OUTER ! End of outer loop over all interpolation points. -!$OMP END DO - -! If INTERP_IN and INTERP_OUT are present, compute all values f(q). -IF (PRESENT(INTERP_IN)) THEN - ! Level 1 parallel loop over all interpolation points. - !$OMP DO SCHEDULE(STATIC) - DO MI = 1, M - ! Check for errors. - IF (IERR(MI) .LE. 1) THEN - ! Compute the weighted sum of vertex response values. - DO K = 1, D+1 - INTERP_OUT(:,MI) = INTERP_OUT(:,MI) & - + INTERP_IN(:,SIMPS(K,MI)) * WEIGHTS(K,MI) - END DO - END IF - END DO - !$OMP END DO -END IF - -! Free optional work arrays. -IF (ALLOCATED(IWORK_DWNNLS)) DEALLOCATE(IWORK_DWNNLS) -IF (ALLOCATED(WORK_DWNNLS)) DEALLOCATE(WORK_DWNNLS) -IF (ALLOCATED(W_DWNNLS)) DEALLOCATE(W_DWNNLS) -IF (ALLOCATED(X_DWNNLS)) DEALLOCATE(X_DWNNLS) -!$OMP END PARALLEL -! End of Level 1 parallel region. - -! Free dynamic work arrays. -DEALLOCATE(WORK) - -RETURN - -CONTAINS ! Internal subroutines and functions. - -SUBROUTINE RESCALE(MINDIST, DIAMETER, SCALE) -! Rescale and transform data to be centered at the origin with unit -! radius. -! -! The parallel implementation of this subroutine exploits parallelism -! over loops of length N. For nested loops, this subroutine follows -! the OpenMP recommendation of a static schedule with a fixed chunk -! size (of 100). -! -! On output, PTS and Q have been rescaled and shifted. All the data -! points in PTS are centered with unit radius, and the points in Q -! have been shifted and scaled in relation to PTS. -! -! MINDIST is a real number containing the (scaled) minimum distance -! between any two data points in PTS. -! -! DIAMETER is a real number containing the (scaled) diameter of the -! data set PTS. -! -! SCALE contains the real factor used to transform the data and -! interpolation points: scaled value = (original value - -! barycenter of data points)/SCALE. - -! Output arguments. -REAL(KIND=R8), INTENT(OUT) :: MINDIST, DIAMETER, SCALE - -! Local variables. -REAL(KIND=R8) :: PTS_CENTER(D) ! The center of the data points PTS. -REAL(KIND=R8) :: DISTANCE ! The current distance. - -! Initialize local values. -MINDIST = HUGE(0.0_R8) -DIAMETER = 0.0_R8 -SCALE = 0.0_R8 - -! Compute barycenter of all data points. -PTS_CENTER(:) = SUM(PTS(:,:), DIM=2)/REAL(N, KIND=R8) -! Center the points. -FORALL (I = 1:N) PTS(:,I) = PTS(:,I) - PTS_CENTER(:) -! Compute the scale factor (for unit radius). -!$OMP PARALLEL DO & -!$OMP& PRIVATE(I, DISTANCE), & -!$OMP& REDUCTION(MAX:SCALE), & -!$OMP& SCHEDULE(STATIC), & -!$OMP& DEFAULT(SHARED) -DO I = 1, N ! Cycle through all points again. - DISTANCE = DNRM2(D, PTS(:,I), 1) ! Compute the distance from the center. - IF (DISTANCE > SCALE) THEN ! Compare to the current radius. - SCALE = DISTANCE - END IF -END DO -!$OMP END PARALLEL DO -! Scale the points to unit radius. -PTS = PTS / SCALE -! Also transform Q similarly. -FORALL (I = 1:M) Q(:,I) = (Q(:,I) - PTS_CENTER(:)) / SCALE -! Compute the minimum and maximum distances. -IF (EXACTL) THEN - ! If exact error error checking is turned on, then compute the DIAMETER - ! and MINDIST values. - !$OMP PARALLEL DO & - !$OMP& PRIVATE(I, DISTANCE), & - !$OMP& REDUCTION(MAX:DIAMETER), & - !$OMP& REDUCTION(MIN:MINDIST), & - !$OMP& SCHEDULE(STATIC, 100), & - !$OMP& DEFAULT(SHARED) - DO I = 1, N ! Cycle through all pairs of points. - DO J = I + 1, N - DISTANCE = DNRM2(D, PTS(:,I) - PTS(:,J), 1) ! Compute the distance. - IF (DISTANCE > DIAMETER) THEN ! Compare to the current diameter. - DIAMETER = DISTANCE - END IF - IF (DISTANCE < MINDIST) THEN ! Compare to the current minimum distance. - MINDIST = DISTANCE - END IF - END DO - END DO - !$OMP END PARALLEL DO -ELSE - ! If exact error checking is turned off, then the diameter is approximately - ! 2.0 after rescaling and centering the points. The MINDIST is not computed. - DIAMETER = 2.0_R8 - MINDIST = 1.0_R8 -END IF -RETURN -END SUBROUTINE RESCALE - -END SUBROUTINE DELAUNAYSPARSEP diff --git a/extras/delsparsepy/delsparse_src/delsparse_bind_c.f90 b/extras/delsparsepy/delsparse_src/delsparse_bind_c.f90 deleted file mode 100644 index 8bf2973..0000000 --- a/extras/delsparsepy/delsparse_src/delsparse_bind_c.f90 +++ /dev/null @@ -1,4422 +0,0 @@ -! This automatically generated Fortran wrapper file allows codes -! written in Fortran to be called directly from C and translates all -! C-style arguments into expected Fortran-style arguments (with -! assumed size, local type declarations, etc.). - - -SUBROUTINE C_DELAUNAYSPARSES(D, N, PTS_DIM_1, PTS_DIM_2, PTS, M, Q_DIM_1, Q_DIM_2, Q, SIMPS_DIM_1, SIMPS_DIM_2, SIMPS, WEIGHTS_DIM_& -&1, WEIGHTS_DIM_2, WEIGHTS, IERR_DIM_1, IERR, INTERP_IN_PRESENT, INTERP_IN_DIM_1, INTERP_IN_DIM_2, INTERP_IN, INTERP_OUT_PRESENT, I& -&NTERP_OUT_DIM_1, INTERP_OUT_DIM_2, INTERP_OUT, EPS_PRESENT, EPS, EXTRAP_PRESENT, EXTRAP, RNORM_PRESENT, RNORM_DIM_1, RNORM, IBUDGE& -&T_PRESENT, IBUDGET, CHAIN_PRESENT, CHAIN, EXACT_PRESENT, EXACT) BIND(C) -USE REAL_PRECISION , ONLY : R8 - IMPLICIT NONE - - INTEGER, INTENT(IN) :: D - - INTEGER, INTENT(IN) :: N - - INTEGER, INTENT(IN) :: PTS_DIM_1 - INTEGER, INTENT(IN) :: PTS_DIM_2 - REAL(KIND=R8), INTENT(INOUT), DIMENSION(PTS_DIM_1,PTS_DIM_2) :: PTS - - INTEGER, INTENT(IN) :: M - - INTEGER, INTENT(IN) :: Q_DIM_1 - INTEGER, INTENT(IN) :: Q_DIM_2 - REAL(KIND=R8), INTENT(INOUT), DIMENSION(Q_DIM_1,Q_DIM_2) :: Q - - INTEGER, INTENT(IN) :: SIMPS_DIM_1 - INTEGER, INTENT(IN) :: SIMPS_DIM_2 - INTEGER, INTENT(OUT), DIMENSION(SIMPS_DIM_1,SIMPS_DIM_2) :: SIMPS - - INTEGER, INTENT(IN) :: WEIGHTS_DIM_1 - INTEGER, INTENT(IN) :: WEIGHTS_DIM_2 - REAL(KIND=R8), INTENT(OUT), DIMENSION(WEIGHTS_DIM_1,WEIGHTS_DIM_2) :: WEIGHTS - - INTEGER, INTENT(IN) :: IERR_DIM_1 - INTEGER, INTENT(OUT), DIMENSION(IERR_DIM_1) :: IERR - - LOGICAL, INTENT(IN) :: INTERP_IN_PRESENT - INTEGER, INTENT(IN) :: INTERP_IN_DIM_1 - INTEGER, INTENT(IN) :: INTERP_IN_DIM_2 - REAL(KIND=R8), INTENT(IN), DIMENSION(INTERP_IN_DIM_1,INTERP_IN_DIM_2) :: INTERP_IN - - LOGICAL, INTENT(IN) :: INTERP_OUT_PRESENT - INTEGER, INTENT(IN) :: INTERP_OUT_DIM_1 - INTEGER, INTENT(IN) :: INTERP_OUT_DIM_2 - REAL(KIND=R8), INTENT(OUT), DIMENSION(INTERP_OUT_DIM_1,INTERP_OUT_DIM_2) :: INTERP_OUT - - LOGICAL, INTENT(IN) :: EPS_PRESENT - REAL(KIND=R8), INTENT(IN) :: EPS - - LOGICAL, INTENT(IN) :: EXTRAP_PRESENT - REAL(KIND=R8), INTENT(IN) :: EXTRAP - - LOGICAL, INTENT(IN) :: RNORM_PRESENT - INTEGER, INTENT(IN) :: RNORM_DIM_1 - REAL(KIND=R8), INTENT(OUT), DIMENSION(RNORM_DIM_1) :: RNORM - - LOGICAL, INTENT(IN) :: IBUDGET_PRESENT - INTEGER, INTENT(IN) :: IBUDGET - - LOGICAL, INTENT(IN) :: CHAIN_PRESENT - LOGICAL, INTENT(IN) :: CHAIN - - LOGICAL, INTENT(IN) :: EXACT_PRESENT - LOGICAL, INTENT(IN) :: EXACT - - INTERFACE - SUBROUTINE DELAUNAYSPARSES(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EX& -&ACT) - ! This is a serial implementation of an algorithm for efficiently performing - ! interpolation in R^D via the Delaunay triangulation. The algorithm is fully - ! described and analyzed in - ! - ! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. - ! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate - ! interpolation in arbitrary dimension via the Delaunay triangulation. In - ! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, - ! USA. Article 12, 8 pages. - ! - ! - ! On input: - ! - ! D is the dimension of the space for PTS and Q. - ! - ! N is the number of data points in PTS. - ! - ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the - ! coordinates of a single data point in R^D. - ! - ! M is the number of interpolation points in Q. - ! - ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the - ! coordinates of a single interpolation point in R^D. - ! - ! - ! On output: - ! - ! PTS and Q have been rescaled and shifted. All the data points in PTS - ! are now contained in the unit hyperball in R^D, and the points in Q - ! have been shifted and scaled accordingly in relation to PTS. - ! - ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns - ! in PTS) for the D+1 vertices of the Delaunay simplex containing each - ! interpolation point in Q. - ! - ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each - ! point in Q as a convex combination of the D+1 corresponding vertices - ! in SIMPS. - ! - ! IERR(1:M) contains integer valued error flags associated with the - ! computation of each of the M interpolation points in Q. The error - ! codes are: - ! - ! 00 : Succesful interpolation. - ! 01 : Succesful extrapolation (up to the allowed extrapolation distance). - ! 02 : This point was outside the allowed extrapolation distance; the - ! corresponding entries in SIMPS and WEIGHTS contain zero values. - ! - ! 10 : The dimension D must be positive. - ! 11 : Too few data points to construct a triangulation (i.e., N < D+1). - ! 12 : No interpolation points given (i.e., M < 1). - ! 13 : The first dimension of PTS does not agree with the dimension D. - ! 14 : The second dimension of PTS does not agree with the number of points N. - ! 15 : The first dimension of Q does not agree with the dimension D. - ! 16 : The second dimension of Q does not agree with the number of - ! interpolation points M. - ! 17 : The first dimension of the output array SIMPS does not match the number - ! of vertices needed for a D-simplex (D+1). - ! 18 : The second dimension of the output array SIMPS does not match the - ! number of interpolation points M. - ! 19 : The first dimension of the output array WEIGHTS does not match the - ! number of vertices for a a D-simplex (D+1). - ! 20 : The second dimension of the output array WEIGHTS does not match the - ! number of interpolation points M. - ! 21 : The size of the error array IERR does not match the number of - ! interpolation points M. - ! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. - ! 23 : The first dimension of INTERP_IN does not match the first - ! dimension of INTERP_OUT. - ! 24 : The second dimension of INTERP_IN does not match the number of - ! data points PTS. - ! 25 : The second dimension of INTERP_OUT does not match the number of - ! interpolation points M. - ! 26 : The budget supplied in IBUDGET does not contain a positive - ! integer. - ! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. - ! 28 : The size of the RNORM output array does not match the number of - ! interpolation points M. - ! - ! 30 : Two or more points in the data set PTS are too close together with - ! respect to the working precision (EPS), which would result in a - ! numerically degenerate simplex. - ! 31 : All the data points in PTS lie in some lower dimensional linear - ! manifold (up to the working precision), and no valid triangulation - ! exists. - ! 40 : An error caused DELAUNAYSPARSES to terminate before this value could - ! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may - ! contain garbage values. - ! - ! 50 : A memory allocation error occurred while allocating the work array - ! WORK. - ! - ! 60 : The budget was exceeded before the algorithm converged on this - ! value. If the dimension is high, try increasing IBUDGET. This - ! error can also be caused by a working precision EPS that is too - ! small for the conditioning of the problem. - ! - ! 61 : A value that was judged appropriate later caused LAPACK to encounter a - ! singularity. Try increasing the value of EPS. - ! - ! 70 : Allocation error for the extrapolation work arrays. - ! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection - ! of an extrapolation point onto the convex hull. - ! 72 : The SLATEC subroutine DWNNLS has reported a usage error. - ! - ! The errors 72, 80--83 should never occur, and likely indicate a - ! compiler bug or hardware failure. - ! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. - ! 81 : The LAPACK subroutine DGETRF has reported an illegal value. - ! 82 : The LAPACK subroutine DGETRS has reported an illegal value. - ! 83 : The LAPACK subroutine DORMQR has reported an illegal value. - ! - ! - ! Optional arguments: - ! - ! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of - ! the data points in PTS on input. The first dimension of INTERP_IN is - ! inferred to be the dimension of these response vectors, and the - ! second dimension must match N. If present, the response values will - ! be computed for each interpolation point in Q, and stored in INTERP_OUT, - ! which therefore must also be present. If both INTERP_IN and INTERP_OUT - ! are omitted, only the containing simplices and convex combination - ! weights are returned. - ! - ! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each - ! interpolation point in Q on output. The first dimension of INTERP_OUT - ! must match the first dimension of INTERP_IN, and the second dimension - ! must match M. If present, the response values at each interpolation - ! point are computed as a convex combination of the response values - ! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing - ! that interpolation point. Therefore, if INTERP_OUT is present, then - ! INTERP_IN must also be present. If both are omitted, only the - ! simplices and convex combination weights are returned. - ! - ! EPS contains the real working precision for the problem on input. By default, - ! EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff for the - ! machine. In general, any values that differ by less than EPS are judged - ! as equal, and any weights that are greater than -EPS are judged as - ! nonnegative. EPS cannot take a value less than the default value of - ! \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, the default - ! value will be used instead automatically. - ! - ! EXTRAP contains the real maximum extrapolation distance (relative to the - ! diameter of PTS) on input. Interpolation at a point outside the convex - ! hull of PTS is done by projecting that point onto the convex hull, and - ! then doing normal Delaunay interpolation at that projection. - ! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) - ! units outside the convex hull of PTS will not be done and an error code - ! of 2 will be returned. Note that computing the projection can be - ! expensive. Setting EXTRAP=0 will cause all extrapolation points to be - ! ignored without ever computing a projection. By default, EXTRAP=0.1 - ! (extrapolate by up to 10% of the diameter of PTS). - ! - ! RNORM(1:M) contains the real unscaled projection (2-norm) distances from - ! any projection computations on output. If not present, these distances - ! are still computed for each extrapolation point, but are never returned. - ! - ! IBUDGET on input contains the integer budget for performing flips while - ! iterating toward the simplex containing each interpolation point in - ! Q. This prevents DELAUNAYSPARSES from falling into an infinite loop when - ! an inappropriate value of EPS is given with respect to the problem - ! conditioning. By default, IBUDGET=50000. However, for extremely - ! high-dimensional problems and pathological inputs, the default value - ! may be insufficient. - ! - ! CHAIN is a logical input argument that determines whether a new first - ! simplex should be constructed for each interpolation point - ! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." - ! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not - ! recommended, unless the size of the triangulation is relatively small - ! or the interpolation points are known to be tightly clustered. - ! - ! EXACT is a logical input argument that determines whether the exact - ! diameter should be computed and whether a check for duplicate data - ! points should be performed in advance. When EXACT=.FALSE., the - ! diameter of PTS is approximated by twice the distance from the - ! barycenter of PTS to the farthest point in PTS, and no check is - ! done to find the closest pair of points, which could result in hard - ! to find bugs later on. When EXACT=.TRUE., the exact diameter is - ! computed and an error is returned whenever PTS contains duplicate - ! values up to the precision EPS. By default EXACT=.TRUE., but setting - ! EXACT=.FALSE. could result in significant speedup when N is large. - ! It is strongly recommended that most users leave EXACT=.TRUE., as - ! setting EXACT=.FALSE. could result in input errors that are difficult - ! to identify. Also, the diameter approximation could be wrong by up to - ! a factor of two. - ! - ! - ! Subroutines and functions directly referenced from BLAS are - ! DDOT, DGEMV, DNRM2, DTRSM, - ! and from LAPACK are - ! DGEQP3, DGETRF, DGETRS, DORMQR. - ! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its - ! SLATEC dependencies have been slightly edited to comply with the Fortran - ! 2008 standard, with all print statements and references to stderr being - ! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 - ! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS - ! Algorithm 777) is used for the real data type. The REAL_PRECISION module, - ! DELAUNAYSPARSES, and DWNNLS and its dependencies comply with the Fortran - ! 2008 standard. - ! - ! Primary Author: Tyler H. Chang - ! Last Update: March, 2020 - ! - USE REAL_PRECISION , ONLY : R8 - IMPLICIT NONE - INTEGER, INTENT(IN) :: D - INTEGER, INTENT(IN) :: N - REAL(KIND=R8), INTENT(INOUT), DIMENSION(:,:) :: PTS - INTEGER, INTENT(IN) :: M - REAL(KIND=R8), INTENT(INOUT), DIMENSION(:,:) :: Q - INTEGER, INTENT(OUT), DIMENSION(:,:) :: SIMPS - REAL(KIND=R8), INTENT(OUT), DIMENSION(:,:) :: WEIGHTS - INTEGER, INTENT(OUT), DIMENSION(:) :: IERR - REAL(KIND=R8), INTENT(IN), OPTIONAL, DIMENSION(:,:) :: INTERP_IN - REAL(KIND=R8), INTENT(OUT), OPTIONAL, DIMENSION(:,:) :: INTERP_OUT - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP - REAL(KIND=R8), INTENT(OUT), OPTIONAL, DIMENSION(:) :: RNORM - INTEGER, INTENT(IN), OPTIONAL :: IBUDGET - LOGICAL, INTENT(IN), OPTIONAL :: CHAIN - LOGICAL, INTENT(IN), OPTIONAL :: EXACT - END SUBROUTINE DELAUNAYSPARSES - END INTERFACE - - IF (INTERP_IN_PRESENT) THEN - IF (INTERP_OUT_PRESENT) THEN - IF (EPS_PRESENT) THEN - IF (EXTRAP_PRESENT) THEN - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM) - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP) - END IF - END IF - END IF - END IF - ELSE - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM) - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EPS=EPS) - END IF - END IF - END IF - END IF - END IF - ELSE - IF (EXTRAP_PRESENT) THEN - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM) - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP) - END IF - END IF - END IF - END IF - ELSE - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, RNORM=RNORM, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, RNORM=RNORM, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, RNORM=RNORM) - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&NTERP_OUT=INTERP_OUT) - END IF - END IF - END IF - END IF - END IF - END IF - ELSE - IF (EPS_PRESENT) THEN - IF (EXTRAP_PRESENT) THEN - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXTRAP=EXTRAP, RNORM=RNORM) - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXTRAP=EXTRAP, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXTRAP=EXTRAP) - END IF - END IF - END IF - END IF - ELSE - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, RNORM=RNORM, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, RNORM=RNORM, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, RNORM=RNORM) - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&PS=EPS) - END IF - END IF - END IF - END IF - END IF - ELSE - IF (EXTRAP_PRESENT) THEN - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XTRAP=EXTRAP, RNORM=RNORM) - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XTRAP=EXTRAP, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XTRAP=EXTRAP, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XTRAP=EXTRAP, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XTRAP=EXTRAP) - END IF - END IF - END IF - END IF - ELSE - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, R& -&NORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, R& -&NORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, R& -&NORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, R& -&NORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, R& -&NORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, R& -&NORM=RNORM, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, R& -&NORM=RNORM, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, R& -&NORM=RNORM) - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&BUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&BUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&BUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& -&BUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, C& -&HAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, C& -&HAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& -&XACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN) - END IF - END IF - END IF - END IF - END IF - END IF - END IF - ELSE - IF (INTERP_OUT_PRESENT) THEN - IF (EPS_PRESENT) THEN - IF (EXTRAP_PRESENT) THEN - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM) - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXTRAP=EXTRAP, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXTRAP=EXTRAP) - END IF - END IF - END IF - END IF - ELSE - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, RNORM=RNORM, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, RNORM=RNORM, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, RNORM=RNORM) - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EPS=EPS) - END IF - END IF - END IF - END IF - END IF - ELSE - IF (EXTRAP_PRESENT) THEN - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXTRAP=EXTRAP, RNORM=RNORM) - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXTRAP=EXTRAP, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXTRAP=EXTRAP, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXTRAP=EXTRAP, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXTRAP=EXTRAP) - END IF - END IF - END IF - END IF - ELSE - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& RNORM=RNORM, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& RNORM=RNORM, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& RNORM=RNORM) - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& -& EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT) - END IF - END IF - END IF - END IF - END IF - END IF - ELSE - IF (EPS_PRESENT) THEN - IF (EXTRAP_PRESENT) THEN - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& -&, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& -&, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& -&, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& -&, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& -&, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& -&, RNORM=RNORM, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& -&, RNORM=RNORM, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& -&, RNORM=RNORM) - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& -&, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& -&, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& -&, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& -&, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& -&, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& -&, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& -&, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& -&) - END IF - END IF - END IF - END IF - ELSE - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM, & -&IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM, & -&IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM, & -&IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM, & -&IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM, & -&CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM, & -&CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM, & -&EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM) - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBUDG& -&ET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBUDG& -&ET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBUDG& -&ET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBUDG& -&ET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, CHAIN=CHAIN, & -&EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS) - END IF - END IF - END IF - END IF - END IF - ELSE - IF (EXTRAP_PRESENT) THEN - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM=R& -&NORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM=R& -&NORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM=R& -&NORM, IBUDGET=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM=R& -&NORM, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM=R& -&NORM, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM=R& -&NORM, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM=R& -&NORM, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM=R& -&NORM) - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDGET& -&=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDGET& -&=IBUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDGET& -&=IBUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDGET& -&=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, CHAIN=C& -&HAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, CHAIN=C& -&HAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, EXACT=E& -&XACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP) - END IF - END IF - END IF - END IF - ELSE - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET=I& -&BUDGET, CHAIN=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET=I& -&BUDGET, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET=I& -&BUDGET, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET=I& -&BUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, CHAIN=CHA& -&IN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, CHAIN=CHA& -&IN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, EXACT=EXA& -&CT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM) - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, CHAIN& -&=CHAIN, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, CHAIN& -&=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, EXACT& -&=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET) - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, CHAIN=CHAIN, EXACT=EXA& -&CT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, CHAIN=CHAIN) - END IF - ELSE - IF (EXACT_PRESENT) THEN - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXACT=EXACT) - ELSE - CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR) - END IF - END IF - END IF - END IF - END IF - END IF - END IF - END IF -END SUBROUTINE C_DELAUNAYSPARSES - - -SUBROUTINE C_DELAUNAYSPARSEP(D, N, PTS_DIM_1, PTS_DIM_2, PTS, M, Q_DIM_1, Q_DIM_2, Q, SIMPS_DIM_1, SIMPS_DIM_2, SIMPS, WEIGHTS_DIM_& -&1, WEIGHTS_DIM_2, WEIGHTS, IERR_DIM_1, IERR, INTERP_IN_PRESENT, INTERP_IN_DIM_1, INTERP_IN_DIM_2, INTERP_IN, INTERP_OUT_PRESENT, I& -&NTERP_OUT_DIM_1, INTERP_OUT_DIM_2, INTERP_OUT, EPS_PRESENT, EPS, EXTRAP_PRESENT, EXTRAP, RNORM_PRESENT, RNORM_DIM_1, RNORM, IBUDGE& -&T_PRESENT, IBUDGET, CHAIN_PRESENT, CHAIN, EXACT_PRESENT, EXACT, PMODE_PRESENT, PMODE) BIND(C) -USE REAL_PRECISION , ONLY : R8 - IMPLICIT NONE - - INTEGER, INTENT(IN) :: D - - INTEGER, INTENT(IN) :: N - - INTEGER, INTENT(IN) :: PTS_DIM_1 - INTEGER, INTENT(IN) :: PTS_DIM_2 - REAL(KIND=R8), INTENT(INOUT), DIMENSION(PTS_DIM_1,PTS_DIM_2) :: PTS - - INTEGER, INTENT(IN) :: M - - INTEGER, INTENT(IN) :: Q_DIM_1 - INTEGER, INTENT(IN) :: Q_DIM_2 - REAL(KIND=R8), INTENT(INOUT), DIMENSION(Q_DIM_1,Q_DIM_2) :: Q - - INTEGER, INTENT(IN) :: SIMPS_DIM_1 - INTEGER, INTENT(IN) :: SIMPS_DIM_2 - INTEGER, INTENT(OUT), DIMENSION(SIMPS_DIM_1,SIMPS_DIM_2) :: SIMPS - - INTEGER, INTENT(IN) :: WEIGHTS_DIM_1 - INTEGER, INTENT(IN) :: WEIGHTS_DIM_2 - REAL(KIND=R8), INTENT(OUT), DIMENSION(WEIGHTS_DIM_1,WEIGHTS_DIM_2) :: WEIGHTS - - INTEGER, INTENT(IN) :: IERR_DIM_1 - INTEGER, INTENT(OUT), DIMENSION(IERR_DIM_1) :: IERR - - LOGICAL, INTENT(IN) :: INTERP_IN_PRESENT - INTEGER, INTENT(IN) :: INTERP_IN_DIM_1 - INTEGER, INTENT(IN) :: INTERP_IN_DIM_2 - REAL(KIND=R8), INTENT(IN), DIMENSION(INTERP_IN_DIM_1,INTERP_IN_DIM_2) :: INTERP_IN - - LOGICAL, INTENT(IN) :: INTERP_OUT_PRESENT - INTEGER, INTENT(IN) :: INTERP_OUT_DIM_1 - INTEGER, INTENT(IN) :: INTERP_OUT_DIM_2 - REAL(KIND=R8), INTENT(OUT), DIMENSION(INTERP_OUT_DIM_1,INTERP_OUT_DIM_2) :: INTERP_OUT - - LOGICAL, INTENT(IN) :: EPS_PRESENT - REAL(KIND=R8), INTENT(IN) :: EPS - - LOGICAL, INTENT(IN) :: EXTRAP_PRESENT - REAL(KIND=R8), INTENT(IN) :: EXTRAP - - LOGICAL, INTENT(IN) :: RNORM_PRESENT - INTEGER, INTENT(IN) :: RNORM_DIM_1 - REAL(KIND=R8), INTENT(OUT), DIMENSION(RNORM_DIM_1) :: RNORM - - LOGICAL, INTENT(IN) :: IBUDGET_PRESENT - INTEGER, INTENT(IN) :: IBUDGET - - LOGICAL, INTENT(IN) :: CHAIN_PRESENT - LOGICAL, INTENT(IN) :: CHAIN - - LOGICAL, INTENT(IN) :: EXACT_PRESENT - LOGICAL, INTENT(IN) :: EXACT - - LOGICAL, INTENT(IN) :: PMODE_PRESENT - INTEGER, INTENT(IN) :: PMODE - - INTERFACE - SUBROUTINE DELAUNAYSPARSEP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EX& -&ACT, PMODE) - ! This is a parallel implementation of an algorithm for efficiently performing - ! interpolation in R^D via the Delaunay triangulation. The algorithm is fully - ! described and analyzed in - ! - ! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. - ! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate - ! interpolation in arbitrary dimension via the Delaunay triangulation. In - ! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, - ! USA. Article 12, 8 pages. - ! - ! - ! On input: - ! - ! D is the dimension of the space for PTS and Q. - ! - ! N is the number of data points in PTS. - ! - ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the - ! coordinates of a single data point in R^D. - ! - ! M is the number of interpolation points in Q. - ! - ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the - ! coordinates of a single interpolation point in R^D. - ! - ! - ! On output: - ! - ! PTS and Q have been rescaled and shifted. All the data points in PTS - ! are now contained in the unit hyperball in R^D, and the points in Q - ! have been shifted and scaled accordingly in relation to PTS. - ! - ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns - ! in PTS) for the D+1 vertices of the Delaunay simplex containing each - ! interpolation point in Q. - ! - ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each - ! point in Q as a convex combination of the D+1 corresponding vertices - ! in SIMPS. - ! - ! IERR(1:M) contains integer valued error flags associated with the - ! computation of each of the M interpolation points in Q. The error - ! codes are: - ! - ! 00 : Succesful interpolation. - ! 01 : Succesful extrapolation (up to the allowed extrapolation distance). - ! 02 : This point was outside the allowed extrapolation distance; the - ! corresponding entries in SIMPS and WEIGHTS contain zero values. - ! - ! 10 : The dimension D must be positive. - ! 11 : Too few data points to construct a triangulation (i.e., N < D+1). - ! 12 : No interpolation points given (i.e., M < 1). - ! 13 : The first dimension of PTS does not agree with the dimension D. - ! 14 : The second dimension of PTS does not agree with the number of points N. - ! 15 : The first dimension of Q does not agree with the dimension D. - ! 16 : The second dimension of Q does not agree with the number of - ! interpolation points M. - ! 17 : The first dimension of the output array SIMPS does not match the number - ! of vertices needed for a D-simplex (D+1). - ! 18 : The second dimension of the output array SIMPS does not match the - ! number of interpolation points M. - ! 19 : The first dimension of the output array WEIGHTS does not match the - ! number of vertices for a a D-simplex (D+1). - ! 20 : The second dimension of the output array WEIGHTS does not match the - ! number of interpolation points M. - ! 21 : The size of the error array IERR does not match the number of - ! interpolation points M. - ! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. - ! 23 : The first dimension of INTERP_IN does not match the first - ! dimension of INTERP_OUT. - ! 24 : The second dimension of INTERP_IN does not match the number of - ! data points PTS. - ! 25 : The second dimension of INTERP_OUT does not match the number of - ! interpolation points M. - ! 26 : The budget supplied in IBUDGET does not contain a positive - ! integer. - ! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. - ! 28 : The size of the RNORM output array does not match the number of - ! interpolation points M. - ! - ! 30 : Two or more points in the data set PTS are too close together with - ! respect to the working precision (EPS), which would result in a - ! numerically degenerate simplex. - ! 31 : All the data points in PTS lie in some lower dimensional linear - ! manifold (up to the working precision), and no valid triangulation - ! exists. - ! 40 : An error caused DELAUNAYSPARSEP to terminate before this value could - ! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may - ! contain garbage values. - ! - ! 50 : A memory allocation error occurred while allocating the work array - ! WORK. - ! - ! 60 : The budget was exceeded before the algorithm converged on this - ! value. If the dimension is high, try increasing IBUDGET. This - ! error can also be caused by a working precision EPS that is too - ! small for the conditioning of the problem. - ! - ! 61 : A value that was judged appropriate later caused LAPACK to encounter a - ! singularity. Try increasing the value of EPS. - ! - ! 70 : Allocation error for the extrapolation work arrays. - ! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection - ! of an extrapolation point onto the convex hull. - ! 72 : The SLATEC subroutine DWNNLS has reported a usage error. - ! - ! The errors 72, 80--83 should never occur, and likely indicate a - ! compiler bug or hardware failure. - ! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. - ! 81 : The LAPACK subroutine DGETRF has reported an illegal value. - ! 82 : The LAPACK subroutine DGETRS has reported an illegal value. - ! 83 : The LAPACK subroutine DORMQR has reported an illegal value. - ! - ! 90 : The value of PMODE is not valid. - ! - ! - ! Optional arguments: - ! - ! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of - ! the data points in PTS on input. The first dimension of INTERP_IN is - ! inferred to be the dimension of these response vectors, and the - ! second dimension must match N. If present, the response values will - ! be computed for each interpolation point in Q, and stored in INTERP_OUT, - ! which therefore must also be present. If both INTERP_IN and INTERP_OUT - ! are omitted, only the containing simplices and convex combination - ! weights are returned. - ! - ! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each - ! interpolation point in Q on output. The first dimension of INTERP_OU - ! must match the first dimension of INTERP_IN, and the second dimension - ! must match M. If present, the response values at each interpolation - ! point are computed as a convex combination of the response values - ! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing - ! that interpolation point. Therefore, if INTERP_OUT is present, then - ! INTERP_IN must also be present. If both are omitted, only the - ! simplices and convex combination weights are returned. - ! - ! EPS contains the real working precision for the problem on input. By - ! default, EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff - ! for the machine. In general, any values that differ by less than EPS - ! are judged as equal, and any weights that are greater than -EPS are - ! judged as nonnegative. EPS cannot take a value less than the default - ! value of \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, - ! the default value will be used instead automatically. - ! - ! EXTRAP contains the real maximum extrapolation distance (relative to the - ! diameter of PTS) on input. Interpolation at a point outside the convex - ! hull of PTS is done by projecting that point onto the convex hull, and - ! then doing normal Delaunay interpolation at that projection. - ! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) - ! units outside the convex hull of PTS will not be done and an error code - ! of 2 will be returned. Note that computing the projection can be - ! expensive. Setting EXTRAP=0 will cause all extrapolation points to be - ! ignored without ever computing a projection. By default, EXTRAP=0.1 - ! (extrapolate by up to 10% of the diameter of PTS). - ! - ! RNORM(1:M) contains the real unscaled projection (2-norm) distances from - ! any projection computations on output. If not present, these distances - ! are still computed for each extrapolation point, but are never returned. - ! - ! IBUDGET on input contains the integer budget for performing flips while - ! iterating toward the simplex containing each interpolation point in Q. - ! This prevents DELAUNAYSPARSEP from falling into an infinite loop when - ! an inappropriate value of EPS is given with respect to the problem - ! conditioning. By default, IBUDGET=50000. However, for extremely - ! high-dimensional problems and pathological inputs, the default value - ! may be insufficient. - ! - ! CHAIN is a logical input argument that determines whether a new first - ! simplex should be constructed for each interpolation point - ! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." - ! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not - ! recommended, unless the size of the triangulation is relatively small - ! or the interpolation points are known to be tightly clustered. - ! - ! EXACT is a logical input argument that determines whether the exact - ! diameter should be computed and whether a check for duplicate data - ! points should be performed in advance. When EXACT=.FALSE., the - ! diameter of PTS is approximated by twice the distance from the - ! barycenter of PTS to the farthest point in PTS, and no check is - ! done to find the closest pair of points, which could result in hard - ! to find bugs later on. When EXACT=.TRUE., the exact diameter is - ! computed and an error is returned whenever PTS contains duplicate - ! values up to the precision EPS. By default EXACT=.TRUE., but setting - ! EXACT=.FALSE. could result in significant speedup when N is large. - ! It is strongly recommended that most users leave EXACT=.TRUE., as - ! setting EXACT=.FALSE. could result in input errors that are difficult - ! to identify. Also, the diameter approximation could be wrong by up to - ! a factor of two. - ! - ! PMODE is an integer specifying the level of parallelism to be exploited. - ! If PMODE = 1, then parallelism is exploited at the level of the loop - ! over all interpolation points (Level 1 parallelism). - ! If PMODE = 2, then parallelism is exploited at the level of the loops - ! over data points when constructing/flipping simplices (Level 2 - ! parallelism). - ! If PMODE = 3, then parallelism is exploited at both levels. Note: this - ! implies that the total number of threads active at any time could be up - ! to OMP_NUM_THREADS^2. - ! By default, PMODE is set to 1 if there is more than 1 interpolation - ! point and 2 otherwise. - ! - ! - ! Subroutines and functions directly referenced from BLAS are - ! DDOT, DGEMV, DNRM2, DTRSM, - ! and from LAPACK are - ! DGEQP3, DGETRF, DGETRS, DORMQR. - ! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its - ! SLATEC dependencies have been slightly edited to comply with the Fortran - ! 2008 standard, with all print statements and references to stderr being - ! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 - ! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS - ! Algorithm 777) is used for the real data type. The REAL_PRECISION module, - ! DELAUNAYSPARSEP, and DWNNLS and its dependencies comply with the Fortran - ! 2008 standard. - ! - ! Primary Author: Tyler H. Chang - ! Last Update: March, 2020 - ! - USE REAL_PRECISION , ONLY : R8 - IMPLICIT NONE - INTEGER, INTENT(IN) :: D - INTEGER, INTENT(IN) :: N - REAL(KIND=R8), INTENT(INOUT), DIMENSION(:,:) :: PTS - INTEGER, INTENT(IN) :: M - REAL(KIND=R8), INTENT(INOUT), DIMENSION(:,:) :: Q - INTEGER, INTENT(OUT), DIMENSION(:,:) :: SIMPS - REAL(KIND=R8), INTENT(OUT), DIMENSION(:,:) :: WEIGHTS - INTEGER, INTENT(OUT), DIMENSION(:) :: IERR - REAL(KIND=R8), INTENT(IN), OPTIONAL, DIMENSION(:,:) :: INTERP_IN - REAL(KIND=R8), INTENT(OUT), OPTIONAL, DIMENSION(:,:) :: INTERP_OUT - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS - REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP - REAL(KIND=R8), INTENT(OUT), OPTIONAL, DIMENSION(:) :: RNORM - INTEGER, INTENT(IN), OPTIONAL :: IBUDGET - LOGICAL, INTENT(IN), OPTIONAL :: CHAIN - LOGICAL, INTENT(IN), OPTIONAL :: EXACT - INTEGER, INTENT(IN), OPTIONAL :: PMODE - END SUBROUTINE DELAUNAYSPARSEP - END INTERFACE - - IF (INTERP_IN_PRESENT) THEN - IF (INTERP_OUT_PRESENT) THEN - IF (EPS_PRESENT) THEN - IF (EXTRAP_PRESENT) THEN - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM) - END IF - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP) - END IF - END IF - END IF - END IF - END IF - ELSE - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM) - END IF - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EPS=EPS) - END IF - END IF - END IF - END IF - END IF - END IF - ELSE - IF (EXTRAP_PRESENT) THEN - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM) - END IF - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP) - END IF - END IF - END IF - END IF - END IF - ELSE - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, RNORM=RNORM, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, RNORM=RNORM, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, RNORM=RNORM, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, RNORM=RNORM) - END IF - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& INTERP_OUT=INTERP_OUT) - END IF - END IF - END IF - END IF - END IF - END IF - END IF - ELSE - IF (EPS_PRESENT) THEN - IF (EXTRAP_PRESENT) THEN - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM) - END IF - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXTRAP=EXTRAP) - END IF - END IF - END IF - END IF - END IF - ELSE - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, RNORM=RNORM, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, RNORM=RNORM, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, RNORM=RNORM, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, RNORM=RNORM) - END IF - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EPS=EPS) - END IF - END IF - END IF - END IF - END IF - END IF - ELSE - IF (EXTRAP_PRESENT) THEN - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, RNORM=RNORM, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, RNORM=RNORM) - END IF - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXTRAP=EXTRAP) - END IF - END IF - END IF - END IF - END IF - ELSE - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& RNORM=RNORM, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& RNORM=RNORM, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& RNORM=RNORM, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& RNORM=RNORM) - END IF - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& -& PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN) - END IF - END IF - END IF - END IF - END IF - END IF - END IF - END IF - ELSE - IF (INTERP_OUT_PRESENT) THEN - IF (EPS_PRESENT) THEN - IF (EXTRAP_PRESENT) THEN - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM) - END IF - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXTRAP=EXTRAP) - END IF - END IF - END IF - END IF - END IF - ELSE - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, RNORM=RNORM, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, RNORM=RNORM, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, RNORM=RNORM) - END IF - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EPS=EPS) - END IF - END IF - END IF - END IF - END IF - END IF - ELSE - IF (EXTRAP_PRESENT) THEN - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, RNORM=RNORM, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, RNORM=RNORM) - END IF - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXTRAP=EXTRAP) - END IF - END IF - END IF - END IF - END IF - ELSE - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, RNORM=RNORM, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, RNORM=RNORM, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, RNORM=RNORM, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, RNORM=RNORM) - END IF - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& -&T) - END IF - END IF - END IF - END IF - END IF - END IF - END IF - ELSE - IF (EPS_PRESENT) THEN - IF (EXTRAP_PRESENT) THEN - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, RNORM=RNORM, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, RNORM=RNORM, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, RNORM=RNORM, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, RNORM=RNORM, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, RNORM=RNORM) - END IF - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& -&AP) - END IF - END IF - END IF - END IF - END IF - ELSE - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& -&, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& -&, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& -&, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& -&, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& -&, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& -&, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& -&, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& -&, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& -&, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& -&, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& -&, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& -&, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& -&, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& -&, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& -&, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& -&) - END IF - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBU& -&DGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBU& -&DGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBU& -&DGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBU& -&DGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBU& -&DGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBU& -&DGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBU& -&DGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBU& -&DGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, CHAIN=CHAIN& -&, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, CHAIN=CHAIN& -&, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, CHAIN=CHAIN& -&, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, CHAIN=CHAIN& -&) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXACT=EXACT& -&, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXACT=EXACT& -&) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, PMODE=PMODE& -&) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS) - END IF - END IF - END IF - END IF - END IF - END IF - ELSE - IF (EXTRAP_PRESENT) THEN - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& -&=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& -&=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& -&=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& -&=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& -&=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& -&=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& -&=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& -&=RNORM, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& -&=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& -&=RNORM, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& -&=RNORM, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& -&=RNORM, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& -&=RNORM, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& -&=RNORM, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& -&=RNORM, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& -&=RNORM) - END IF - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDG& -&ET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDG& -&ET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDG& -&ET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDG& -&ET=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDG& -&ET=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDG& -&ET=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDG& -&ET=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDG& -&ET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, CHAIN& -&=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, CHAIN& -&=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, CHAIN& -&=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, CHAIN& -&=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, EXACT& -&=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, EXACT& -&=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, PMODE& -&=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP) - END IF - END IF - END IF - END IF - END IF - ELSE - IF (RNORM_PRESENT) THEN - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET& -&=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET& -&=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET& -&=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET& -&=IBUDGET, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET& -&=IBUDGET, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET& -&=IBUDGET, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET& -&=IBUDGET, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET& -&=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, CHAIN=C& -&HAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, CHAIN=C& -&HAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, CHAIN=C& -&HAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, CHAIN=C& -&HAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, EXACT=E& -&XACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, EXACT=E& -&XACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, PMODE=P& -&MODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM) - END IF - END IF - END IF - END IF - ELSE - IF (IBUDGET_PRESENT) THEN - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, CHA& -&IN=CHAIN, EXACT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, CHA& -&IN=CHAIN, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, CHA& -&IN=CHAIN, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, CHA& -&IN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, EXA& -&CT=EXACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, EXA& -&CT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, PMO& -&DE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET) - END IF - END IF - END IF - ELSE - IF (CHAIN_PRESENT) THEN - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, CHAIN=CHAIN, EXACT=E& -&XACT, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, CHAIN=CHAIN, EXACT=E& -&XACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, CHAIN=CHAIN, PMODE=P& -&MODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, CHAIN=CHAIN) - END IF - END IF - ELSE - IF (EXACT_PRESENT) THEN - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXACT=EXACT, PMODE=P& -&MODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXACT=EXACT) - END IF - ELSE - IF (PMODE_PRESENT) THEN - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, PMODE=PMODE) - ELSE - CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR) - END IF - END IF - END IF - END IF - END IF - END IF - END IF - END IF - END IF -END SUBROUTINE C_DELAUNAYSPARSEP - diff --git a/extras/delsparsepy/delsparse_src/lapack.f b/extras/delsparsepy/delsparse_src/lapack.f deleted file mode 100755 index 3dff8b8..0000000 --- a/extras/delsparsepy/delsparse_src/lapack.f +++ /dev/null @@ -1,4369 +0,0 @@ - SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine (version 3.7.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -* -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER INB, INBMIN, IXOVER - PARAMETER( INB = 1, INBMIN = 2, IXOVER = 3 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, - $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN -* .. -* .. External Subroutines .. - EXTERNAL DGEQRF, DLAQP2, DLAQPS, DORMQR, DSWAP, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - DOUBLE PRECISION DNRM2 - EXTERNAL ILAENV, DNRM2 -* .. -* .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test input arguments -* ==================== -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF -* - IF( INFO.EQ.0 ) THEN - MINMN = MIN( M, N ) - IF( MINMN.EQ.0 ) THEN - IWS = 1 - LWKOPT = 1 - ELSE - IWS = 3*N + 1 - NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) - LWKOPT = 2*N + ( N + 1 )*NB - END IF - WORK( 1 ) = LWKOPT -* - IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQP3', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Move initial columns up front. -* - NFXD = 1 - DO 10 J = 1, N - IF( JPVT( J ).NE.0 ) THEN - IF( J.NE.NFXD ) THEN - CALL DSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 ) - JPVT( J ) = JPVT( NFXD ) - JPVT( NFXD ) = J - ELSE - JPVT( J ) = J - END IF - NFXD = NFXD + 1 - ELSE - JPVT( J ) = J - END IF - 10 CONTINUE - NFXD = NFXD - 1 -* -* Factorize fixed columns -* ======================= -* -* Compute the QR factorization of fixed columns and update -* remaining columns. -* - IF( NFXD.GT.0 ) THEN - NA = MIN( M, NFXD ) -*CC CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) - CALL DGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO ) - IWS = MAX( IWS, INT( WORK( 1 ) ) ) - IF( NA.LT.N ) THEN -*CC CALL DORM2R( 'LEFT', 'TRANSPOSE', M, N-NA, NA, A, LDA, -*CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) - CALL DORMQR( 'LEFT', 'TRANSPOSE', M, N-NA, NA, A, LDA, TAU, - $ A( 1, NA+1 ), LDA, WORK, LWORK, INFO ) - IWS = MAX( IWS, INT( WORK( 1 ) ) ) - END IF - END IF -* -* Factorize free columns -* ====================== -* - IF( NFXD.LT.MINMN ) THEN -* - SM = M - NFXD - SN = N - NFXD - SMINMN = MINMN - NFXD -* -* Determine the block size. -* - NB = ILAENV( INB, 'DGEQRF', ' ', SM, SN, -1, -1 ) - NBMIN = 2 - NX = 0 -* - IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN -* -* Determine when to cross over from blocked to unblocked -* code. -* - NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', SM, SN, -1, - $ -1 ) ) -* -* - IF( NX.LT.SMINMN ) THEN -* -* Determine if workspace is large enough for blocked code. -* - MINWS = 2*SN + ( SN+1 )*NB - IWS = MAX( IWS, MINWS ) - IF( LWORK.LT.MINWS ) THEN -* -* Not enough workspace to use optimal NB: Reduce NB and -* determine the minimum value of NB. -* - NB = ( LWORK-2*SN ) / ( SN+1 ) - NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', SM, N, - $ -1, -1 ) ) -* -* - END IF - END IF - END IF -* -* Initialize partial column norms. The first N elements of work -* store the exact column norms. -* - DO 20 J = NFXD + 1, N - WORK( J ) = DNRM2( SM, A( NFXD+1, J ), 1 ) - WORK( N+J ) = WORK( J ) - 20 CONTINUE -* - IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. - $ ( NX.LT.SMINMN ) ) THEN -* -* Use blocked code initially. -* - J = NFXD + 1 -* -* Compute factorization: while loop. -* -* - TOPBMN = MINMN - NX - 30 CONTINUE - IF( J.LE.TOPBMN ) THEN - JB = MIN( NB, TOPBMN-J+1 ) -* -* Factorize JB columns among columns J:N. -* - CALL DLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, - $ JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ), - $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 ) -* - J = J + FJB - GO TO 30 - END IF - ELSE - J = NFXD + 1 - END IF -* -* Use unblocked code to factor the last or only block. -* -* - IF( J.LE.MINMN ) - $ CALL DLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), - $ TAU( J ), WORK( J ), WORK( N+J ), - $ WORK( 2*N+1 ) ) -* - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DGEQP3 -* - END - SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGEQR2 computes a QR factorization of a real m by n matrix A: -* A = Q * R. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix A. -* On exit, the elements on and above the diagonal of the array -* contain the min(m,n) by n upper trapezoidal matrix R (R is -* upper triangular if m >= n); the elements below the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of elementary reflectors (see Further Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(1) H(2) . . . H(k), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v**T -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, K - DOUBLE PRECISION AII -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQR2', -INFO ) - RETURN - END IF -* - K = MIN( M, N ) -* - DO 10 I = 1, K -* -* Generate elementary reflector H(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAU( I ) ) - IF( I.LT.N ) THEN -* -* Apply H(i) to A(i:m,i+1:n) from the left -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = AII - END IF - 10 CONTINUE - RETURN -* -* End of DGEQR2 -* - END - SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGEQRF computes a QR factorization of a real M-by-N matrix A: -* A = Q * R. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix A. -* On exit, the elements on and above the diagonal of the array -* contain the min(M,N)-by-N upper trapezoidal matrix R (R is -* upper triangular if m >= n); the elements below the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of min(m,n) elementary reflectors (see Further -* Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension -* (MAX(1,LWORK)) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is -* the optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(1) H(2) . . . H(k), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v**T -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQRF', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, - $ -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code initially -* - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -* -* Compute the QR factorization of the current block -* A(i:m,i:i+ib-1) -* - CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H**T to A(i:m,i+ib:n) from the left -* - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF - 10 CONTINUE - ELSE - I = 1 - END IF -* -* Use unblocked code to factor the last or only block. -* - IF( I.LE.K ) - $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* - WORK( 1 ) = IWS - RETURN -* -* End of DGEQRF -* - END - SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETF2 computes an LU factorization of a general m-by-n matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, U(k,k) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION SFMIN - INTEGER I, J, JP -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - INTEGER IDAMAX - EXTERNAL DLAMCH, IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DGER, DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Compute machine safe minimum -* - SFMIN = DLAMCH('S') -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP - IF( A( JP, J ).NE.ZERO ) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* Compute elements J+1:M of J-th column. -* - IF( J.LT.M ) THEN - IF( ABS(A( J, J )) .GE. SFMIN ) THEN - CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) - ELSE - DO 20 I = 1, M-J - A( J+I, J ) = A( J+I, J ) / A( J, J ) - 20 CONTINUE - END IF - END IF -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, - $ A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of DGETF2 -* - END - SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETRF computes an LU factorization of a general M-by-N matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL DGETF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGETRF -* - END - SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGETRS solves a system of linear equations -* A * X = B or A**T * X = B -* with a general N-by-N matrix A using the LU factorization computed -* by DGETRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A**T* X = B (Transpose) -* = 'C': A**T* X = B (Conjugate transpose = Transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The factors L and U from the factorization A = P*L*U -* as computed by DGETRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from DGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLASWP, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( NOTRAN ) THEN -* -* Solve A * X = B. -* -* Apply row interchanges to the right hand sides. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A**T * X = B. -* -* Solve U**T *X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve L**T *X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of DGETRS -* - END - DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. -* -* Purpose -* ======= -* -* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary -* overflow. -* -* Arguments -* ========= -* -* X (input) DOUBLE PRECISION -* Y (input) DOUBLE PRECISION -* X and Y specify the values x and y. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION W, XABS, YABS, Z -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - XABS = ABS( X ) - YABS = ABS( Y ) - W = MAX( XABS, YABS ) - Z = MIN( XABS, YABS ) - IF( Z.EQ.ZERO ) THEN - DLAPY2 = W - ELSE - DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) - END IF - RETURN -* -* End of DLAPY2 -* - END - SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, - $ WORK ) -* -* -- LAPACK auxiliary routine (version 3.7.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -* -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER LDA, M, N, OFFSET -* .. -* .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), - $ WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, ITEMP, J, MN, OFFPI, PVT - DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, DSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DNRM2 - EXTERNAL IDAMAX, DLAMCH, DNRM2 -* .. -* .. Executable Statements .. -* - MN = MIN( M-OFFSET, N ) - TOL3Z = SQRT(DLAMCH('EPSILON')) -* -* Compute factorization. -* - DO 20 I = 1, MN -* - OFFPI = OFFSET + I -* -* Determine ith pivot column and swap if necessary. -* - PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 ) -* - IF( PVT.NE.I ) THEN - CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) - ITEMP = JPVT( PVT ) - JPVT( PVT ) = JPVT( I ) - JPVT( I ) = ITEMP - VN1( PVT ) = VN1( I ) - VN2( PVT ) = VN2( I ) - END IF -* -* Generate elementary reflector H(i). -* - IF( OFFPI.LT.M ) THEN - CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, - $ TAU( I ) ) - ELSE - CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) - END IF -* - IF( I.LT.N ) THEN -* -* Apply H(i)**T to A(offset+i:m,i+1:n) from the left. -* - AII = A( OFFPI, I ) - A( OFFPI, I ) = ONE - CALL DLARF( 'LEFT', M-OFFPI+1, N-I, A( OFFPI, I ), 1, - $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) - A( OFFPI, I ) = AII - END IF -* -* Update partial column norms. -* - DO 10 J = I + 1, N - IF( VN1( J ).NE.ZERO ) THEN -* -* NOTE: The following 4 lines follow from the analysis in -* Lapack Working Note 176. -* - TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 - IF( TEMP2 .LE. TOL3Z ) THEN - IF( OFFPI.LT.M ) THEN - VN1( J ) = DNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) - VN2( J ) = VN1( J ) - ELSE - VN1( J ) = ZERO - VN2( J ) = ZERO - END IF - ELSE - VN1( J ) = VN1( J )*SQRT( TEMP ) - END IF - END IF - 10 CONTINUE -* - 20 CONTINUE -* - RETURN -* -* End of DLAQP2 -* - END - SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, - $ VN2, AUXV, F, LDF ) -* -* -- LAPACK auxiliary routine (version 3.7.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -* -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER KB, LDA, LDF, M, N, NB, OFFSET -* .. -* .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), - $ VN1( * ), VN2( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK - DOUBLE PRECISION AKK, TEMP, TEMP2, TOL3Z -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, NINT, SQRT -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DNRM2 - EXTERNAL IDAMAX, DLAMCH, DNRM2 -* .. -* .. Executable Statements .. -* - LASTRK = MIN( M, N+OFFSET ) - LSTICC = 0 - K = 0 - TOL3Z = SQRT(DLAMCH('EPSILON')) -* -* Beginning of while loop. -* - 10 CONTINUE - IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN - K = K + 1 - RK = OFFSET + K -* -* Determine ith pivot column and swap if necessary -* - PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) - IF( PVT.NE.K ) THEN - CALL DSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 ) - CALL DSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF ) - ITEMP = JPVT( PVT ) - JPVT( PVT ) = JPVT( K ) - JPVT( K ) = ITEMP - VN1( PVT ) = VN1( K ) - VN2( PVT ) = VN2( K ) - END IF -* -* Apply previous Householder reflectors to column K: -* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**T. -* - IF( K.GT.1 ) THEN - CALL DGEMV( 'NO TRANSPOSE', M-RK+1, K-1, -ONE, A( RK, 1 ), - $ LDA, F( K, 1 ), LDF, ONE, A( RK, K ), 1 ) - END IF -* -* Generate elementary reflector H(k). -* - IF( RK.LT.M ) THEN - CALL DLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) - ELSE - CALL DLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) - END IF -* - AKK = A( RK, K ) - A( RK, K ) = ONE -* -* Compute Kth column of F: -* -* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**T*A(RK:M,K). -* - IF( K.LT.N ) THEN - CALL DGEMV( 'TRANSPOSE', M-RK+1, N-K, TAU( K ), - $ A( RK, K+1 ), LDA, A( RK, K ), 1, ZERO, - $ F( K+1, K ), 1 ) - END IF -* -* Padding F(1:K,K) with zeros. -* - DO 20 J = 1, K - F( J, K ) = ZERO - 20 CONTINUE -* -* Incremental updating of F: -* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**T -* *A(RK:M,K). -* - IF( K.GT.1 ) THEN - CALL DGEMV( 'TRANSPOSE', M-RK+1, K-1, -TAU( K ), A( RK, 1 ), - $ LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 ) -* - CALL DGEMV( 'NO TRANSPOSE', N, K-1, ONE, F( 1, 1 ), LDF, - $ AUXV( 1 ), 1, ONE, F( 1, K ), 1 ) - END IF -* -* Update the current row of A: -* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**T. -* - IF( K.LT.N ) THEN - CALL DGEMV( 'NO TRANSPOSE', N-K, K, -ONE, F( K+1, 1 ), LDF, - $ A( RK, 1 ), LDA, ONE, A( RK, K+1 ), LDA ) - END IF -* -* Update partial column norms. -* - IF( RK.LT.LASTRK ) THEN - DO 30 J = K + 1, N - IF( VN1( J ).NE.ZERO ) THEN -* -* NOTE: The following 4 lines follow from the analysis -* in -* Lapack Working Note 176. -* - TEMP = ABS( A( RK, J ) ) / VN1( J ) - TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) - TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 - IF( TEMP2 .LE. TOL3Z ) THEN - VN2( J ) = DBLE( LSTICC ) - LSTICC = J - ELSE - VN1( J ) = VN1( J )*SQRT( TEMP ) - END IF - END IF - 30 CONTINUE - END IF -* - A( RK, K ) = AKK -* -* End of while loop. -* - GO TO 10 - END IF - KB = K - RK = OFFSET + KB -* -* Apply the block reflector to the rest of the matrix: -* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - -* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**T. -* - IF( KB.LT.MIN( N, M-OFFSET ) ) THEN - CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M-RK, N-KB, KB, -ONE, - $ A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, - $ A( RK+1, KB+1 ), LDA ) - END IF -* -* Recomputation of difficult columns. -* - 40 CONTINUE - IF( LSTICC.GT.0 ) THEN - ITEMP = NINT( VN2( LSTICC ) ) - VN1( LSTICC ) = DNRM2( M-RK, A( RK+1, LSTICC ), 1 ) -* -* NOTE: The computation of VN1( LSTICC ) relies on the fact that -* SNRM2 does not fail on vectors with norm below the value of -* SQRT(DLAMCH('S')) -* - VN2( LSTICC ) = VN1( LSTICC ) - LSTICC = ITEMP - GO TO 40 - END IF -* - RETURN -* -* End of DLAQPS -* - END - SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER SIDE - INTEGER INCV, LDC, M, N - DOUBLE PRECISION TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLARF applies a real elementary reflector H to a real m by n matrix -* C, from either the left or the right. H is represented in the form -* -* H = I - tau * v * v**T -* -* where tau is a real scalar and v is a real vector. -* -* If tau = 0, then H is taken to be the unit matrix. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': form H * C -* = 'R': form C * H -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* V (input) DOUBLE PRECISION array, dimension -* (1 + (M-1)*abs(INCV)) if SIDE = 'L' -* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' -* The vector v in the representation of H. V is not used if -* TAU = 0. -* -* INCV (input) INTEGER -* The increment between elements of v. INCV <> 0. -* -* TAU (input) DOUBLE PRECISION -* The value tau in the representation of H. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by the matrix H * C if SIDE = 'L', -* or C * H if SIDE = 'R'. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* (N) if SIDE = 'L' -* or (M) if SIDE = 'R' -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL APPLYLEFT - INTEGER I, LASTV, LASTC -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DGER -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILADLR, ILADLC - EXTERNAL LSAME, ILADLR, ILADLC -* .. -* .. Executable Statements .. -* - APPLYLEFT = LSAME( SIDE, 'L' ) - LASTV = 0 - LASTC = 0 - IF( TAU.NE.ZERO ) THEN -! Set up variables for scanning V. LASTV begins pointing to the end -! of V. - IF( APPLYLEFT ) THEN - LASTV = M - ELSE - LASTV = N - END IF - IF( INCV.GT.0 ) THEN - I = 1 + (LASTV-1) * INCV - ELSE - I = 1 - END IF -! Look for the last non-zero row in V. - DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) - LASTV = LASTV - 1 - I = I - INCV - END DO - IF( APPLYLEFT ) THEN -! Scan for the last non-zero column in C(1:lastv,:). - LASTC = ILADLC(LASTV, N, C, LDC) - ELSE -! Scan for the last non-zero row in C(:,1:lastv). - LASTC = ILADLR(M, LASTV, C, LDC) - END IF - END IF -! Note that lastc.eq.0 renders the BLAS operations null; no special -! case is needed at this level. - IF( APPLYLEFT ) THEN -* -* Form H * C -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) -* - CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, - $ ZERO, WORK, 1 ) -* -* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * -* w(1:lastc,1)**T -* - CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) - END IF - ELSE -* -* Form C * H -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) -* - CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, - $ V, INCV, ZERO, WORK, 1 ) -* -* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * -* v(1:lastv,1)**T -* - CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) - END IF - END IF - RETURN -* -* End of DLARF -* - END - SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, - $ T, LDT, C, LDC, WORK, LDWORK ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, SIDE, STOREV, TRANS - INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), - $ WORK( LDWORK, * ) -* .. -* -* Purpose -* ======= -* -* DLARFB applies a real block reflector H or its transpose H**T to a -* real m by n matrix C, from either the left or the right. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply H or H**T from the Left -* = 'R': apply H or H**T from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply H (No transpose) -* = 'T': apply H**T (Transpose) -* -* DIRECT (input) CHARACTER*1 -* Indicates how H is formed from a product of elementary -* reflectors -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Indicates how the vectors which define the elementary -* reflectors are stored: -* = 'C': Columnwise -* = 'R': Rowwise -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* K (input) INTEGER -* The order of the matrix T (= the number of elementary -* reflectors whose product defines the block reflector). -* -* V (input) DOUBLE PRECISION array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,M) if STOREV = 'R' and SIDE = 'L' -* (LDV,N) if STOREV = 'R' and SIDE = 'R' -* The matrix V. See Further Details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); -* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); -* if STOREV = 'R', LDV >= K. -* -* T (input) DOUBLE PRECISION array, dimension (LDT,K) -* The triangular k by k matrix T in the representation of the -* block reflector. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) -* -* LDWORK (input) INTEGER -* The leading dimension of the array WORK. -* If SIDE = 'L', LDWORK >= max(1,N); -* if SIDE = 'R', LDWORK >= max(1,M). -* -* Further Details -* =============== -* -* The shape of the matrix V and the storage of the vectors which define -* the H(i) is best illustrated by the following example with n = 5 and -* k = 3. The elements equal to 1 are not stored; the corresponding -* array elements are modified but restored on exit. The rest of the -* array is not used. -* -* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -* -* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -* ( v1 1 ) ( 1 v2 v2 v2 ) -* ( v1 v2 1 ) ( 1 v3 v3 ) -* ( v1 v2 v3 ) -* ( v1 v2 v3 ) -* -* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -* -* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -* ( v1 v2 v3 ) ( v2 v2 v2 1 ) -* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -* ( 1 v3 ) -* ( 1 ) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - CHARACTER TRANST - INTEGER I, J, LASTV, LASTC -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILADLR, ILADLC - EXTERNAL LSAME, ILADLR, ILADLC -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DTRMM -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( LSAME( TRANS, 'N' ) ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* - IF( LSAME( STOREV, 'C' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 ) (first K rows) -* ( V2 ) -* where V1 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in -* WORK) -* -* W := C1**T -* - DO 10 J = 1, K - CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 10 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2**T *V2 -* - CALL DGEMM( 'Transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**T -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - V2 * W**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**T -* - DO 30 J = 1, K - DO 20 I = 1, LASTC - C( J, I ) = C( J, I ) - WORK( I, J ) - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C1 -* - DO 40 J = 1, K - CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) - 40 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2 * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**T -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - W * V2**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 60 J = 1, K - DO 50 I = 1, LASTC - C( I, J ) = C( I, J ) - WORK( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - ELSE -* -* Let V = ( V1 ) -* ( V2 ) (last K rows) -* where V2 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in -* WORK) -* -* W := C2**T -* - DO 70 J = 1, K - CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - 70 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1**T*V1 -* - CALL DGEMM( 'Transpose', 'No transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**T -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - V1 * W**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) - END IF -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) -* -* C2 := C2 - W**T -* - DO 90 J = 1, K - DO 80 I = 1, LASTC - C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C2 -* - DO 100 J = 1, K - CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 100 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1 * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**T -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - W * V1**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) - END IF -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) -* -* C2 := C2 - W -* - DO 120 J = 1, K - DO 110 I = 1, LASTC - C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) - 110 CONTINUE - 120 CONTINUE - END IF - END IF -* - ELSE IF( LSAME( STOREV, 'R' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 V2 ) (V1: first K columns) -* where V1 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) -* (stored in WORK) -* -* W := C1**T -* - DO 130 J = 1, K - CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 130 CONTINUE -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2**T*V2**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**T * W**T -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - V2**T * W**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, - $ ONE, C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**T -* - DO 150 J = 1, K - DO 140 I = 1, LASTC - C( J, I ) = C( J, I ) - WORK( I, J ) - 140 CONTINUE - 150 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) -* -* W := C1 -* - DO 160 J = 1, K - CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) - 160 CONTINUE -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2 * V2**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - W * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 180 J = 1, K - DO 170 I = 1, LASTC - C( I, J ) = C( I, J ) - WORK( I, J ) - 170 CONTINUE - 180 CONTINUE -* - END IF -* - ELSE -* -* Let V = ( V1 V2 ) (V2: last K columns) -* where V2 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) -* (stored in WORK) -* -* W := C2**T -* - DO 190 J = 1, K - CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - 190 CONTINUE -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1**T * V1**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**T * W**T -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - V1**T * W**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) -* -* C2 := C2 - W**T -* - DO 210 J = 1, K - DO 200 I = 1, LASTC - C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) - 200 CONTINUE - 210 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) -* -* W := C2 -* - DO 220 J = 1, K - CALL DCOPY( LASTC, C( 1, LASTV-K+J ), 1, - $ WORK( 1, J ), 1 ) - 220 CONTINUE -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1 * V1**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - W * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 240 J = 1, K - DO 230 I = 1, LASTC - C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) - 230 CONTINUE - 240 CONTINUE -* - END IF -* - END IF - END IF -* - RETURN -* -* End of DLARFB -* - END - SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION ALPHA, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* Purpose -* ======= -* -* DLARFG generates a real elementary reflector H of order n, such -* that -* -* H * ( alpha ) = ( beta ), H**T * H = I. -* ( x ) ( 0 ) -* -* where alpha and beta are scalars, and x is an (n-1)-element real -* vector. H is represented in the form -* -* H = I - tau * ( 1 ) * ( 1 v**T ) , -* ( v ) -* -* where tau is a real scalar and v is a real (n-1)-element -* vector. -* -* If the elements of x are all zero, then tau = 0 and H is taken to be -* the unit matrix. -* -* Otherwise 1 <= tau <= 2. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the elementary reflector. -* -* ALPHA (input/output) DOUBLE PRECISION -* On entry, the value alpha. -* On exit, it is overwritten with the value beta. -* -* X (input/output) DOUBLE PRECISION array, dimension -* (1+(N-2)*abs(INCX)) -* On entry, the vector x. -* On exit, it is overwritten with the vector v. -* -* INCX (input) INTEGER -* The increment between elements of X. INCX > 0. -* -* TAU (output) DOUBLE PRECISION -* The value tau. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, KNT - DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 - EXTERNAL DLAMCH, DLAPY2, DNRM2 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN -* .. -* .. External Subroutines .. - EXTERNAL DSCAL -* .. -* .. Executable Statements .. -* - IF( N.LE.1 ) THEN - TAU = ZERO - RETURN - END IF -* - XNORM = DNRM2( N-1, X, INCX ) -* - IF( XNORM.EQ.ZERO ) THEN -* -* H = I -* - TAU = ZERO - ELSE -* -* general case -* - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) - KNT = 0 - IF( ABS( BETA ).LT.SAFMIN ) THEN -* -* XNORM, BETA may be inaccurate; scale X and recompute them -* - RSAFMN = ONE / SAFMIN - 10 CONTINUE - KNT = KNT + 1 - CALL DSCAL( N-1, RSAFMN, X, INCX ) - BETA = BETA*RSAFMN - ALPHA = ALPHA*RSAFMN - IF( ABS( BETA ).LT.SAFMIN ) - $ GO TO 10 -* -* New BETA is at most 1, at least SAFMIN -* - XNORM = DNRM2( N-1, X, INCX ) - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - END IF - TAU = ( BETA-ALPHA ) / BETA - CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) -* -* If ALPHA is subnormal, it may lose relative accuracy -* - DO 20 J = 1, KNT - BETA = BETA*SAFMIN - 20 CONTINUE - ALPHA = BETA - END IF -* - RETURN -* -* End of DLARFG -* - END - SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* Purpose -* ======= -* -* DLARFT forms the triangular factor T of a real block reflector H -* of order n, which is defined as a product of k elementary reflectors. -* -* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; -* -* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. -* -* If STOREV = 'C', the vector which defines the elementary reflector -* H(i) is stored in the i-th column of the array V, and -* -* H = I - V * T * V**T -* -* If STOREV = 'R', the vector which defines the elementary reflector -* H(i) is stored in the i-th row of the array V, and -* -* H = I - V**T * T * V -* -* Arguments -* ========= -* -* DIRECT (input) CHARACTER*1 -* Specifies the order in which the elementary reflectors are -* multiplied to form the block reflector: -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Specifies how the vectors which define the elementary -* reflectors are stored (see also Further Details): -* = 'C': columnwise -* = 'R': rowwise -* -* N (input) INTEGER -* The order of the block reflector H. N >= 0. -* -* K (input) INTEGER -* The order of the triangular factor T (= the number of -* elementary reflectors). K >= 1. -* -* V (input/output) DOUBLE PRECISION array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,N) if STOREV = 'R' -* The matrix V. See further details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i). -* -* T (output) DOUBLE PRECISION array, dimension (LDT,K) -* The k by k triangular factor T of the block reflector. -* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is -* lower triangular. The rest of the array is not used. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* Further Details -* =============== -* -* The shape of the matrix V and the storage of the vectors which define -* the H(i) is best illustrated by the following example with n = 5 and -* k = 3. The elements equal to 1 are not stored; the corresponding -* array elements are modified but restored on exit. The rest of the -* array is not used. -* -* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -* -* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -* ( v1 1 ) ( 1 v2 v2 v2 ) -* ( v1 v2 1 ) ( 1 v3 v3 ) -* ( v1 v2 v3 ) -* ( v1 v2 v3 ) -* -* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -* -* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -* ( v1 v2 v3 ) ( v2 v2 v2 1 ) -* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -* ( 1 v3 ) -* ( 1 ) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, PREVLASTV, LASTV - DOUBLE PRECISION VII -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DTRMV -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - PREVLASTV = N - DO 20 I = 1, K - PREVLASTV = MAX( I, PREVLASTV ) - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 10 J = 1, I - T( J, I ) = ZERO - 10 CONTINUE - ELSE -* -* general case -* - VII = V( I, I ) - V( I, I ) = ONE - IF( LSAME( STOREV, 'C' ) ) THEN -! Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) -* - CALL DGEMV( 'Transpose', J-I+1, I-1, -TAU( I ), - $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, - $ T( 1, I ), 1 ) - ELSE -! Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T -* - CALL DGEMV( 'No transpose', I-1, J-I+1, -TAU( I ), - $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, - $ T( 1, I ), 1 ) - END IF - V( I, I ) = VII -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MAX( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - 20 CONTINUE - ELSE - PREVLASTV = 1 - DO 40 I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 30 J = I, K - T( J, I ) = ZERO - 30 CONTINUE - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN - VII = V( N-K+I, I ) - V( N-K+I, I ) = ONE -! Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) := -* - tau(i) * V(j:n-k+i,i+1:k)**T * -* V(j:n-k+i,i) -* - CALL DGEMV( 'Transpose', N-K+I-J+1, K-I, -TAU( I ), - $ V( J, I+1 ), LDV, V( J, I ), 1, ZERO, - $ T( I+1, I ), 1 ) - V( N-K+I, I ) = VII - ELSE - VII = V( I, N-K+I ) - V( I, N-K+I ) = ONE -! Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) := -* - tau(i) * V(i+1:k,j:n-k+i) * -* V(i,j:n-k+i)**T -* - CALL DGEMV( 'No transpose', K-I, N-K+I-J+1, - $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, - $ ZERO, T( I+1, I ), 1 ) - V( I, N-K+I ) = VII - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - T( I, I ) = TAU( I ) - END IF - 40 CONTINUE - END IF - RETURN -* -* End of DLARFT -* - END - SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASWP performs a series of row interchanges on the matrix A. -* One row interchange is initiated for each of rows K1 through K2 of A. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the matrix of column dimension N to which the row -* interchanges will be applied. -* On exit, the permuted matrix. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* -* K1 (input) INTEGER -* The first element of IPIV for which a row interchange will -* be done. -* -* K2 (input) INTEGER -* The last element of IPIV for which a row interchange will -* be done. -* -* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) -* The vector of pivot indices. Only the elements in positions -* K1 through K2 of IPIV are accessed. -* IPIV(K) = L implies rows K and L are to be interchanged. -* -* INCX (input) INTEGER -* The increment between successive values of IPIV. If IPIV -* is negative, the pivots are applied in reverse order. -* -* Further Details -* =============== -* -* Modified by -* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - DOUBLE PRECISION TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) for each of rows K1 through K2. -* - IF( INCX.GT.0 ) THEN - IX0 = K1 - I1 = K1 - I2 = K2 - INC = 1 - ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX - I1 = K2 - I2 = K1 - INC = -1 - ELSE - RETURN - END IF -* - N32 = ( N / 32 )*32 - IF( N32.NE.0 ) THEN - DO 30 J = 1, N32, 32 - IX = IX0 - DO 20 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 10 K = J, J + 31 - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 10 CONTINUE - END IF - IX = IX + INCX - 20 CONTINUE - 30 CONTINUE - END IF - IF( N32.NE.N ) THEN - N32 = N32 + 1 - IX = IX0 - DO 50 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 40 K = N32, N - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 40 CONTINUE - END IF - IX = IX + INCX - 50 CONTINUE - END IF -* - RETURN -* -* End of DLASWP -* - END - SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORM2R overwrites the general real m by n matrix C with -* -* Q * C if SIDE = 'L' and TRANS = 'N', or -* -* Q**T* C if SIDE = 'L' and TRANS = 'T', or -* -* C * Q if SIDE = 'R' and TRANS = 'N', or -* -* C * Q**T if SIDE = 'R' and TRANS = 'T', -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**T from the Left -* = 'R': apply Q or Q**T from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply Q (No transpose) -* = 'T': apply Q**T (Transpose) -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGEQRF in the first k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* (N) if SIDE = 'L', -* (M) if SIDE = 'R' -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORM2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) - $ THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), - $ LDC, WORK ) - A( I, I ) = AII - 10 CONTINUE - RETURN -* -* End of DORM2R -* - END - SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORMQR overwrites the general real M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'T': Q**T * C C * Q**T -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**T from the Left; -* = 'R': apply Q or Q**T from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'T': Transpose, apply Q**T. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGEQRF in the first k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension -* (MAX(1,LWORK)) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW -* .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = MAX( 1, NW )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - ELSE - IWS = NW - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), T, LDT ) - IF( LEFT ) THEN -* -* H or H**T is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H**T is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H**T -* - CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, - $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, - $ WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMQR -* - END - DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) -* -* -- LAPACK auxiliary routine (version 3.3.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* Based on LAPACK DLAMCH but with Fortran 95 query functions -* See: http://www.cs.utk.edu/~luszczek/lapack/lamch.html -* and -* http://www.netlib.org/lapack-dev/lapack-coding/program-style.html#id2537289 -* July 2010 -* -* .. Scalar Arguments .. - CHARACTER CMACH -* .. -* -* Purpose -* ======= -* -* DLAMCH determines double precision machine parameters. -* -* Arguments -* ========= -* -* CMACH (input) CHARACTER*1 -* Specifies the value to be returned by DLAMCH: -* = 'E' or 'e', DLAMCH := eps -* = 'S' or 's , DLAMCH := sfmin -* = 'B' or 'b', DLAMCH := base -* = 'P' or 'p', DLAMCH := eps*base -* = 'N' or 'n', DLAMCH := t -* = 'R' or 'r', DLAMCH := rnd -* = 'M' or 'm', DLAMCH := emin -* = 'U' or 'u', DLAMCH := rmin -* = 'L' or 'l', DLAMCH := emax -* = 'O' or 'o', DLAMCH := rmax -* -* where -* -* eps = relative machine precision -* sfmin = safe minimum, such that 1/sfmin does not overflow -* base = base of the machine -* prec = eps*base -* t = number of (base) digits in the mantissa -* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise -* emin = minimum exponent before (gradual) underflow -* rmin = underflow threshold - base**(emin-1) -* emax = largest exponent before overflow -* rmax = overflow threshold - (base**emax)*(1-eps) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, - $ MINEXPONENT, RADIX, TINY -* .. -* .. Executable Statements .. -* -* -* Assume rounding, not chopping. Always. -* - RND = ONE -* - IF( ONE.EQ.RND ) THEN - EPS = EPSILON(ZERO) * 0.5 - ELSE - EPS = EPSILON(ZERO) - END IF -* - IF( LSAME( CMACH, 'E' ) ) THEN - RMACH = EPS - ELSE IF( LSAME( CMACH, 'S' ) ) THEN - SFMIN = TINY(ZERO) - SMALL = ONE / HUGE(ZERO) - IF( SMALL.GE.SFMIN ) THEN -* -* Use SMALL plus a bit, to avoid the possibility of rounding -* causing overflow when computing 1/sfmin. -* - SFMIN = SMALL*( ONE+EPS ) - END IF - RMACH = SFMIN - ELSE IF( LSAME( CMACH, 'B' ) ) THEN - RMACH = RADIX(ZERO) - ELSE IF( LSAME( CMACH, 'P' ) ) THEN - RMACH = EPS * RADIX(ZERO) - ELSE IF( LSAME( CMACH, 'N' ) ) THEN - RMACH = DIGITS(ZERO) - ELSE IF( LSAME( CMACH, 'R' ) ) THEN - RMACH = RND - ELSE IF( LSAME( CMACH, 'M' ) ) THEN - RMACH = MINEXPONENT(ZERO) - ELSE IF( LSAME( CMACH, 'U' ) ) THEN - RMACH = tiny(zero) - ELSE IF( LSAME( CMACH, 'L' ) ) THEN - RMACH = MAXEXPONENT(ZERO) - ELSE IF( LSAME( CMACH, 'O' ) ) THEN - RMACH = HUGE(ZERO) - ELSE - RMACH = ZERO - END IF -* - DLAMCH = RMACH - RETURN -* -* End of DLAMCH -* - END -************************************************************************ -* - INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER ISPEC - REAL ONE, ZERO -* .. -* -* Purpose -* ======= -* -* IEEECK is called from the ILAENV to verify that Infinity and -* possibly NaN arithmetic is safe (i.e. will not trap). -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies whether to test just for inifinity arithmetic -* or whether to test for infinity and NaN arithmetic. -* = 0: Verify infinity arithmetic only. -* = 1: Verify infinity and NaN arithmetic. -* -* ZERO (input) REAL -* Must contain the value 0.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* ONE (input) REAL -* Must contain the value 1.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* RETURN VALUE: INTEGER -* = 0: Arithmetic failed to produce the correct answers -* = 1: Arithmetic produced the correct answers -* -* ===================================================================== -* -* .. Local Scalars .. - REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, - $ NEGZRO, NEWZRO, POSINF -* .. -* .. Executable Statements .. - IEEECK = 1 -* - POSINF = ONE / ZERO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = -ONE / ZERO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGZRO = ONE / ( NEGINF+ONE ) - IF( NEGZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = ONE / NEGZRO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEWZRO = NEGZRO + ZERO - IF( NEWZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = ONE / NEWZRO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = NEGINF*POSINF - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = POSINF*POSINF - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* -* -* -* -* Return if we were only asked to check infinity arithmetic -* - IF( ISPEC.EQ.0 ) - $ RETURN -* - NAN1 = POSINF + NEGINF -* - NAN2 = POSINF / NEGINF -* - NAN3 = POSINF / POSINF -* - NAN4 = POSINF*ZERO -* - NAN5 = NEGINF*NEGZRO -* - NAN6 = NAN5*ZERO -* - IF( NAN1.EQ.NAN1 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN2.EQ.NAN2 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN3.EQ.NAN3 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN4.EQ.NAN4 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN5.EQ.NAN5 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN6.EQ.NAN6 ) THEN - IEEECK = 0 - RETURN - END IF -* - RETURN - END - INTEGER FUNCTION ILADLC( M, N, A, LDA ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.2.2) -- -* -* -- June 2010 -- -* -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ILADLC scans A for its last non-zero column. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The m by n matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( N.EQ.0 ) THEN - ILADLC = N - ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILADLC = N - ELSE -* Now scan each column from the end, returning with the first -* non-zero. - DO ILADLC = N, 1, -1 - DO I = 1, M - IF( A(I, ILADLC).NE.ZERO ) RETURN - END DO - END DO - END IF - RETURN - END - INTEGER FUNCTION ILADLR( M, N, A, LDA ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ILADLR scans A for its last non-zero row. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The m by n matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( M.EQ.0 ) THEN - ILADLR = M - ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILADLR = M - ELSE -* Scan up each column tracking the last zero row seen. - ILADLR = 0 - DO J = 1, N - I=M - DO WHILE ((A(I,J).NE.ZERO).AND.(I.GE.1)) - I=I-1 - ENDDO - ILADLR = MAX( ILADLR, I ) - END DO - END IF - RETURN - END - INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) -* -* -- LAPACK auxiliary routine (version 3.2.1) -- -* -* -- April 2009 -- -* -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER*( * ) NAME, OPTS - INTEGER ISPEC, N1, N2, N3, N4 -* .. -* -* Purpose -* ======= -* -* ILAENV is called from the LAPACK routines to choose problem-dependent -* parameters for the local environment. See ISPEC for a description of -* the parameters. -* -* ILAENV returns an INTEGER -* if ILAENV >= 0: ILAENV returns the value of the parameter specified -* by ISPEC -* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal -* value. -* -* This version provides a set of parameters which should give good, -* but not optimal, performance on many of the currently available -* computers. Users are encouraged to modify this subroutine to set -* the tuning parameters for their particular machine using the option -* and problem size information in the arguments. -* -* This routine will not function correctly if it is converted to all -* lower case. Converting it to all upper case is allowed. -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies the parameter to be returned as the value of -* ILAENV. -* = 1: the optimal blocksize; if this value is 1, an unblocked -* algorithm will give the best performance. -* = 2: the minimum block size for which the block routine -* should be used; if the usable block size is less than -* this value, an unblocked routine should be used. -* = 3: the crossover point (in a block routine, for N less -* than this value, an unblocked routine should be used) -* = 4: the number of shifts, used in the nonsymmetric -* eigenvalue routines (DEPRECATED) -* = 5: the minimum column dimension for blocking to be used; -* rectangular blocks must have dimension at least k by m, -* where k is given by ILAENV(2,...) and m by ILAENV(5,...) -* = 6: the crossover point for the SVD (when reducing an m by n -* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds -* this value, a QR factorization is used first to reduce -* the matrix to a triangular form.) -* = 7: the number of processors -* = 8: the crossover point for the multishift QR method -* for nonsymmetric eigenvalue problems (DEPRECATED) -* = 9: maximum size of the subproblems at the bottom of the -* computation tree in the divide-and-conquer algorithm -* (used by xGELSD and xGESDD) -* =10: ieee NaN arithmetic can be trusted not to trap -* =11: infinity arithmetic can be trusted not to trap -* 12 <= ISPEC <= 16: -* xHSEQR or one of its subroutines, -* see IPARMQ for detailed explanation -* -* NAME (input) CHARACTER*(*) -* The name of the calling subroutine, in either upper case or -* lower case. -* -* OPTS (input) CHARACTER*(*) -* The character options to the subroutine NAME, concatenated -* into a single character string. For example, UPLO = 'U', -* TRANS = 'T', and DIAG = 'N' for a triangular routine would -* be specified as OPTS = 'UTN'. -* -* N1 (input) INTEGER -* N2 (input) INTEGER -* N3 (input) INTEGER -* N4 (input) INTEGER -* Problem dimensions for the subroutine NAME; these may not all -* be required. -* -* Further Details -* =============== -* -* The following conventions have been used when calling ILAENV from the -* LAPACK routines: -* 1) OPTS is a concatenation of all of the character options to -* subroutine NAME, in the same order that they appear in the -* argument list for NAME, even if they are not used in determining -* the value of the parameter specified by ISPEC. -* 2) The problem dimensions N1, N2, N3, N4 are specified in the order -* that they appear in the argument list for NAME. N1 is used -* first, N2 second, and so on, and unused problem dimensions are -* passed a value of -1. -* 3) The parameter value returned by ILAENV is checked for validity in -* the calling subroutine. For example, ILAENV is used to retrieve -* the optimal blocksize for STRTRI as follows: -* -* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) -* IF( NB.LE.1 ) NB = MAX( 1, N ) -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IC, IZ, NB, NBMIN, NX - LOGICAL CNAME, SNAME - CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 -* .. -* .. Intrinsic Functions .. - INTRINSIC CHAR, ICHAR, INT, MIN, REAL -* .. -* .. External Functions .. - INTEGER IEEECK, IPARMQ - EXTERNAL IEEECK, IPARMQ -* .. -* .. Executable Statements .. -* - GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, - $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC -* -* Invalid value for ISPEC -* - ILAENV = -1 - RETURN -* - 10 CONTINUE -* -* Convert NAME to upper case if the first character is lower case. -* - ILAENV = 1 - SUBNAM = NAME - IC = ICHAR( SUBNAM( 1: 1 ) ) - IZ = ICHAR( 'Z' ) - IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN -* -* ASCII character set -* - IF( IC.GE.97 .AND. IC.LE.122 ) THEN - SUBNAM( 1: 1 ) = CHAR( IC-32 ) - DO 20 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( IC.GE.97 .AND. IC.LE.122 ) - $ SUBNAM( I: I ) = CHAR( IC-32 ) - 20 CONTINUE - END IF -* - ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN -* -* EBCDIC character set -* - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN - SUBNAM( 1: 1 ) = CHAR( IC+64 ) - DO 30 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: - $ I ) = CHAR( IC+64 ) - 30 CONTINUE - END IF -* - ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN -* -* Prime machines: ASCII+128 -* - IF( IC.GE.225 .AND. IC.LE.250 ) THEN - SUBNAM( 1: 1 ) = CHAR( IC-32 ) - DO 40 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( IC.GE.225 .AND. IC.LE.250 ) - $ SUBNAM( I: I ) = CHAR( IC-32 ) - 40 CONTINUE - END IF - END IF -* - C1 = SUBNAM( 1: 1 ) - SNAME = C1.EQ.'S' .OR. C1.EQ.'D' - CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' - IF( .NOT.( CNAME .OR. SNAME ) ) - $ RETURN - C2 = SUBNAM( 2: 3 ) - C3 = SUBNAM( 4: 6 ) - C4 = C3( 2: 3 ) -* - GO TO ( 50, 60, 70 )ISPEC -* - 50 CONTINUE -* -* ISPEC = 1: block size -* -* In these examples, separate code is provided for setting NB for -* real and complex. We assume that NB will take the same value in -* single or double precision. -* - NB = 1 -* - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'PO' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRF' ) THEN - NB = 64 - ELSE IF( C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - END IF - ELSE IF( C2.EQ.'GB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'PB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'TR' ) THEN - IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'LA' ) THEN - IF( C3.EQ.'UUM' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN - IF( C3.EQ.'EBZ' ) THEN - NB = 1 - END IF - END IF - ILAENV = NB - RETURN -* - 60 CONTINUE -* -* ISPEC = 2: minimum block size -* - NBMIN = 2 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. - $ 'QLF' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NBMIN = 8 - ELSE - NBMIN = 8 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - END IF - END IF - ILAENV = NBMIN - RETURN -* - 70 CONTINUE -* -* ISPEC = 3: crossover point -* - NX = 0 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. - $ 'QLF' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NX = 128 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NX = 128 - END IF - END IF - END IF - ILAENV = NX - RETURN -* - 80 CONTINUE -* -* ISPEC = 4: number of shifts (used by xHSEQR) -* - ILAENV = 6 - RETURN -* - 90 CONTINUE -* -* ISPEC = 5: minimum column dimension (not used) -* - ILAENV = 2 - RETURN -* - 100 CONTINUE -* -* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) -* - ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) - RETURN -* - 110 CONTINUE -* -* ISPEC = 7: number of processors (not used) -* - ILAENV = 1 - RETURN -* - 120 CONTINUE -* -* ISPEC = 8: crossover point for multishift (used by xHSEQR) -* - ILAENV = 50 - RETURN -* - 130 CONTINUE -* -* ISPEC = 9: maximum size of the subproblems at the bottom of the -* computation tree in the divide-and-conquer algorithm -* (used by xGELSD and xGESDD) -* - ILAENV = 25 - RETURN -* - 140 CONTINUE -* -* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap -* -* ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 1, 0.0, 1.0 ) - END IF - RETURN -* - 150 CONTINUE -* -* ISPEC = 11: infinity arithmetic can be trusted not to trap -* -* ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 0, 0.0, 1.0 ) - END IF - RETURN -* - 160 CONTINUE -* -* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. -* - ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) - RETURN -* -* End of ILAENV -* - END - INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - INTEGER IHI, ILO, ISPEC, LWORK, N - CHARACTER NAME*( * ), OPTS*( * ) -* -* Purpose -* ======= -* -* This program sets problem and machine dependent parameters -* useful for xHSEQR and its subroutines. It is called whenever -* ILAENV is called with 12 <= ISPEC <= 16 -* -* Arguments -* ========= -* -* ISPEC (input) integer scalar -* ISPEC specifies which tunable parameter IPARMQ should -* return. -* -* ISPEC=12: (INMIN) Matrices of order nmin or less -* are sent directly to xLAHQR, the implicit -* double shift QR algorithm. NMIN must be -* at least 11. -* -* ISPEC=13: (INWIN) Size of the deflation window. -* This is best set greater than or equal to -* the number of simultaneous shifts NS. -* Larger matrices benefit from larger deflation -* windows. -* -* ISPEC=14: (INIBL) Determines when to stop nibbling and -* invest in an (expensive) multi-shift QR sweep. -* If the aggressive early deflation subroutine -* finds LD converged eigenvalues from an order -* NW deflation window and LD.GT.(NW*NIBBLE)/100, -* then the next QR sweep is skipped and early -* deflation is applied immediately to the -* remaining active diagonal block. Setting -* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a -* multi-shift QR sweep whenever early deflation -* finds a converged eigenvalue. Setting -* IPARMQ(ISPEC=14) greater than or equal to 100 -* prevents TTQRE from skipping a multi-shift -* QR sweep. -* -* ISPEC=15: (NSHFTS) The number of simultaneous shifts in -* a multi-shift QR iteration. -* -* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the -* following meanings. -* 0: During the multi-shift QR sweep, -* xLAQR5 does not accumulate reflections and -* does not use matrix-matrix multiply to -* update the far-from-diagonal matrix -* entries. -* 1: During the multi-shift QR sweep, -* xLAQR5 and/or xLAQRaccumulates reflections -* and uses -* matrix-matrix multiply to update the -* far-from-diagonal matrix entries. -* 2: During the multi-shift QR sweep. -* xLAQR5 accumulates reflections and takes -* advantage of 2-by-2 block structure during -* matrix-matrix multiplies. -* (If xTRMM is slower than xGEMM, then -* IPARMQ(ISPEC=16)=1 may be more efficient than -* IPARMQ(ISPEC=16)=2 despite the greater level of -* arithmetic work implied by the latter choice.) -* -* NAME (input) character string -* Name of the calling subroutine -* -* OPTS (input) character string -* This is a concatenation of the string arguments to -* TTQRE. -* -* N (input) integer scalar -* N is the order of the Hessenberg matrix H. -* -* ILO (input) INTEGER -* IHI (input) INTEGER -* It is assumed that H is already upper triangular -* in rows and columns 1:ILO-1 and IHI+1:N. -* -* LWORK (input) integer scalar -* The amount of workspace available. -* -* Further Details -* =============== -* -* Little is known about how best to choose these parameters. -* It is possible to use different values of the parameters -* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. -* -* It is probably best to choose different parameters for -* different matrices and different parameters at different -* times during the iteration, but this has not been -* implemented --- yet. -* -* -* The best choices of most of the parameters depend -* in an ill-understood way on the relative execution -* rate of xLAQR3 and xLAQR5 and on the nature of each -* particular eigenvalue problem. Experiment may be the -* only practical way to determine which choices are most -* effective. -* -* Following is a list of default values supplied by IPARMQ. -* These defaults may be adjusted in order to attain better -* performance in any particular computational environment. -* -* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. -* Default: 75. (Must be at least 11.) -* -* IPARMQ(ISPEC=13) Recommended deflation window size. -* This depends on ILO, IHI and NS, the -* number of simultaneous shifts returned -* by IPARMQ(ISPEC=15). The default for -* (IHI-ILO+1).LE.500 is NS. The default -* for (IHI-ILO+1).GT.500 is 3*NS/2. -* -* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. -* -* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. -* a multi-shift QR iteration. -* -* If IHI-ILO+1 is ... -* -* greater than ...but less ... the -* or equal to ... than default is -* -* 0 30 NS = 2+ -* 30 60 NS = 4+ -* 60 150 NS = 10 -* 150 590 NS = ** -* 590 3000 NS = 64 -* 3000 6000 NS = 128 -* 6000 infinity NS = 256 -* -* (+) By default matrices of this order are -* passed to the implicit double shift routine -* xLAHQR. See IPARMQ(ISPEC=12) above. These -* values of NS are used only in case of a rare -* xLAHQR failure. -* -* (**) The asterisks (**) indicate an ad-hoc -* function increasing from 10 to 64. -* -* IPARMQ(ISPEC=16) Select structured matrix multiply. -* (See ISPEC=16 above for details.) -* Default: 3. -* -* ================================================================ -* .. Parameters .. - INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 - PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, - $ ISHFTS = 15, IACC22 = 16 ) - INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP - PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, - $ NIBBLE = 14, KNWSWP = 500 ) - REAL TWO - PARAMETER ( TWO = 2.0 ) -* .. -* .. Local Scalars .. - INTEGER NH, NS -* .. -* .. Intrinsic Functions .. - INTRINSIC LOG, MAX, MOD, NINT, REAL -* .. -* .. Executable Statements .. - IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. - $ ( ISPEC.EQ.IACC22 ) ) THEN -* -* ==== Set the number simultaneous shifts ==== -* - NH = IHI - ILO + 1 - NS = 2 - IF( NH.GE.30 ) - $ NS = 4 - IF( NH.GE.60 ) - $ NS = 10 - IF( NH.GE.150 ) - $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) - IF( NH.GE.590 ) - $ NS = 64 - IF( NH.GE.3000 ) - $ NS = 128 - IF( NH.GE.6000 ) - $ NS = 256 - NS = MAX( 2, NS-MOD( NS, 2 ) ) - END IF -* - IF( ISPEC.EQ.INMIN ) THEN -* -* -* ===== Matrices of order smaller than NMIN get sent -* . to xLAHQR, the classic double shift algorithm. -* . This must be at least 11. ==== -* - IPARMQ = NMIN -* - ELSE IF( ISPEC.EQ.INIBL ) THEN -* -* ==== INIBL: skip a multi-shift qr iteration and -* . whenever aggressive early deflation finds -* . at least (NIBBLE*(window size)/100) deflations. ==== -* - IPARMQ = NIBBLE -* - ELSE IF( ISPEC.EQ.ISHFTS ) THEN -* -* ==== NSHFTS: The number of simultaneous shifts ===== -* - IPARMQ = NS -* - ELSE IF( ISPEC.EQ.INWIN ) THEN -* -* ==== NW: deflation window size. ==== -* - IF( NH.LE.KNWSWP ) THEN - IPARMQ = NS - ELSE - IPARMQ = 3*NS / 2 - END IF -* - ELSE IF( ISPEC.EQ.IACC22 ) THEN -* -* ==== IACC22: Whether to accumulate reflections -* . before updating the far-from-diagonal elements -* . and whether to use 2-by-2 block structure while -* . doing it. A small amount of work could be saved -* . by making this choice dependent also upon the -* . NH=IHI-ILO+1. -* - IPARMQ = 0 - IF( NS.GE.KACMIN ) - $ IPARMQ = 1 - IF( NS.GE.K22MIN ) - $ IPARMQ = 2 -* - ELSE -* ===== invalid value of ispec ===== - IPARMQ = -1 -* - END IF -* -* ==== End of IPARMQ ==== -* - END - diff --git a/extras/delsparsepy/delsparse_src/real_precision.f90 b/extras/delsparsepy/delsparse_src/real_precision.f90 deleted file mode 100644 index 511e265..0000000 --- a/extras/delsparsepy/delsparse_src/real_precision.f90 +++ /dev/null @@ -1,4 +0,0 @@ -MODULE REAL_PRECISION ! HOMPACK90 module for 64-bit arithmetic. -INTEGER, PARAMETER:: R8=SELECTED_REAL_KIND(13) -END MODULE REAL_PRECISION - diff --git a/extras/delsparsepy/delsparse_src/slatec.f b/extras/delsparsepy/delsparse_src/slatec.f deleted file mode 100755 index c652a26..0000000 --- a/extras/delsparsepy/delsparse_src/slatec.f +++ /dev/null @@ -1,5023 +0,0 @@ -*DECK DLSEI - SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, - + RNORML, MODE, WS, IP) -C***BEGIN PROLOGUE DLSEI -C***PURPOSE Solve a linearly constrained least squares problem with -C equality and inequality constraints, and optionally compute -C a covariance matrix. -C***LIBRARY SLATEC -C***CATEGORY K1A2A, D9 -C***TYPE DOUBLE PRECISION (LSEI-S, DLSEI-D) -C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, -C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, -C QUADRATIC PROGRAMMING -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Abstract -C -C This subprogram solves a linearly constrained least squares -C problem with both equality and inequality constraints, and, if the -C user requests, obtains a covariance matrix of the solution -C parameters. -C -C Suppose there are given matrices E, A and G of respective -C dimensions ME by N, MA by N and MG by N, and vectors F, B and H of -C respective lengths ME, MA and MG. This subroutine solves the -C linearly constrained least squares problem -C -C EX = F, (E ME by N) (equations to be exactly -C satisfied) -C AX = B, (A MA by N) (equations to be -C approximately satisfied, -C least squares sense) -C GX .GE. H,(G MG by N) (inequality constraints) -C -C The inequalities GX .GE. H mean that every component of the -C product GX must be .GE. the corresponding component of H. -C -C In case the equality constraints cannot be satisfied, a -C generalized inverse solution residual vector length is obtained -C for F-EX. This is the minimal length possible for F-EX. -C -C Any values ME .GE. 0, MA .GE. 0, or MG .GE. 0 are permitted. The -C rank of the matrix E is estimated during the computation. We call -C this value KRANKE. It is an output parameter in IP(1) defined -C below. Using a generalized inverse solution of EX=F, a reduced -C least squares problem with inequality constraints is obtained. -C The tolerances used in these tests for determining the rank -C of E and the rank of the reduced least squares problem are -C given in Sandia Tech. Rept. SAND-78-1290. They can be -C modified by the user if new values are provided in -C the option list of the array PRGOPT(*). -C -C The user must dimension all arrays appearing in the call list.. -C W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2) -C where K=MAX(MA+MG,N). This allows for a solution of a range of -C problems in the given working space. The dimension of WS(*) -C given is a necessary overestimate. Once a particular problem -C has been run, the output parameter IP(3) gives the actual -C dimension required for that problem. -C -C The parameters for DLSEI( ) are -C -C Input.. All TYPE REAL variables are DOUBLE PRECISION -C -C W(*,*),MDW, The array W(*,*) is doubly subscripted with -C ME,MA,MG,N first dimensioning parameter equal to MDW. -C For this discussion let us call M = ME+MA+MG. Then -C MDW must satisfy MDW .GE. M. The condition -C MDW .LT. M is an error. -C -C The array W(*,*) contains the matrices and vectors -C -C (E F) -C (A B) -C (G H) -C -C in rows and columns 1,...,M and 1,...,N+1 -C respectively. -C -C The integers ME, MA, and MG are the -C respective matrix row dimensions -C of E, A and G. Each matrix has N columns. -C -C PRGOPT(*) This real-valued array is the option vector. -C If the user is satisfied with the nominal -C subprogram features set -C -C PRGOPT(1)=1 (or PRGOPT(1)=1.0) -C -C Otherwise PRGOPT(*) is a linked list consisting of -C groups of data of the following form -C -C LINK -C KEY -C DATA SET -C -C The parameters LINK and KEY are each one word. -C The DATA SET can be comprised of several words. -C The number of items depends on the value of KEY. -C The value of LINK points to the first -C entry of the next group of data within -C PRGOPT(*). The exception is when there are -C no more options to change. In that -C case, LINK=1 and the values KEY and DATA SET -C are not referenced. The general layout of -C PRGOPT(*) is as follows. -C -C ...PRGOPT(1) = LINK1 (link to first entry of next group) -C . PRGOPT(2) = KEY1 (key to the option change) -C . PRGOPT(3) = data value (data value for this change) -C . . -C . . -C . . -C ...PRGOPT(LINK1) = LINK2 (link to the first entry of -C . next group) -C . PRGOPT(LINK1+1) = KEY2 (key to the option change) -C . PRGOPT(LINK1+2) = data value -C ... . -C . . -C . . -C ...PRGOPT(LINK) = 1 (no more options to change) -C -C Values of LINK that are nonpositive are errors. -C A value of LINK .GT. NLINK=100000 is also an error. -C This helps prevent using invalid but positive -C values of LINK that will probably extend -C beyond the program limits of PRGOPT(*). -C Unrecognized values of KEY are ignored. The -C order of the options is arbitrary and any number -C of options can be changed with the following -C restriction. To prevent cycling in the -C processing of the option array, a count of the -C number of options changed is maintained. -C Whenever this count exceeds NOPT=1000, an error -C message is printed and the subprogram returns. -C -C Options.. -C -C KEY=1 -C Compute in W(*,*) the N by N -C covariance matrix of the solution variables -C as an output parameter. Nominally the -C covariance matrix will not be computed. -C (This requires no user input.) -C The data set for this option is a single value. -C It must be nonzero when the covariance matrix -C is desired. If it is zero, the covariance -C matrix is not computed. When the covariance matrix -C is computed, the first dimensioning parameter -C of the array W(*,*) must satisfy MDW .GE. MAX(M,N). -C -C KEY=10 -C Suppress scaling of the inverse of the -C normal matrix by the scale factor RNORM**2/ -C MAX(1, no. of degrees of freedom). This option -C only applies when the option for computing the -C covariance matrix (KEY=1) is used. With KEY=1 and -C KEY=10 used as options the unscaled inverse of the -C normal matrix is returned in W(*,*). -C The data set for this option is a single value. -C When it is nonzero no scaling is done. When it is -C zero scaling is done. The nominal case is to do -C scaling so if option (KEY=1) is used alone, the -C matrix will be scaled on output. -C -C KEY=2 -C Scale the nonzero columns of the -C entire data matrix. -C (E) -C (A) -C (G) -C -C to have length one. The data set for this -C option is a single value. It must be -C nonzero if unit length column scaling -C is desired. -C -C KEY=3 -C Scale columns of the entire data matrix -C (E) -C (A) -C (G) -C -C with a user-provided diagonal matrix. -C The data set for this option consists -C of the N diagonal scaling factors, one for -C each matrix column. -C -C KEY=4 -C Change the rank determination tolerance for -C the equality constraint equations from -C the nominal value of SQRT(DRELPR). This quantity can -C be no smaller than DRELPR, the arithmetic- -C storage precision. The quantity DRELPR is the -C largest positive number such that T=1.+DRELPR -C satisfies T .EQ. 1. The quantity used -C here is internally restricted to be at -C least DRELPR. The data set for this option -C is the new tolerance. -C -C KEY=5 -C Change the rank determination tolerance for -C the reduced least squares equations from -C the nominal value of SQRT(DRELPR). This quantity can -C be no smaller than DRELPR, the arithmetic- -C storage precision. The quantity used -C here is internally restricted to be at -C least DRELPR. The data set for this option -C is the new tolerance. -C -C For example, suppose we want to change -C the tolerance for the reduced least squares -C problem, compute the covariance matrix of -C the solution parameters, and provide -C column scaling for the data matrix. For -C these options the dimension of PRGOPT(*) -C must be at least N+9. The Fortran statements -C defining these options would be as follows: -C -C PRGOPT(1)=4 (link to entry 4 in PRGOPT(*)) -C PRGOPT(2)=1 (covariance matrix key) -C PRGOPT(3)=1 (covariance matrix wanted) -C -C PRGOPT(4)=7 (link to entry 7 in PRGOPT(*)) -C PRGOPT(5)=5 (least squares equas. tolerance key) -C PRGOPT(6)=... (new value of the tolerance) -C -C PRGOPT(7)=N+9 (link to entry N+9 in PRGOPT(*)) -C PRGOPT(8)=3 (user-provided column scaling key) -C -C CALL DCOPY (N, D, 1, PRGOPT(9), 1) (Copy the N -C scaling factors from the user array D(*) -C to PRGOPT(9)-PRGOPT(N+8)) -C -C PRGOPT(N+9)=1 (no more options to change) -C -C The contents of PRGOPT(*) are not modified -C by the subprogram. -C The options for WNNLS( ) can also be included -C in this array. The values of KEY recognized -C by WNNLS( ) are 6, 7 and 8. Their functions -C are documented in the usage instructions for -C subroutine WNNLS( ). Normally these options -C do not need to be modified when using DLSEI( ). -C -C IP(1), The amounts of working storage actually -C IP(2) allocated for the working arrays WS(*) and -C IP(*), respectively. These quantities are -C compared with the actual amounts of storage -C needed by DLSEI( ). Insufficient storage -C allocated for either WS(*) or IP(*) is an -C error. This feature was included in DLSEI( ) -C because miscalculating the storage formulas -C for WS(*) and IP(*) might very well lead to -C subtle and hard-to-find execution errors. -C -C The length of WS(*) must be at least -C -C LW = 2*(ME+N)+K+(MG+2)*(N+7) -C -C where K = max(MA+MG,N) -C This test will not be made if IP(1).LE.0. -C -C The length of IP(*) must be at least -C -C LIP = MG+2*N+2 -C This test will not be made if IP(2).LE.0. -C -C Output.. All TYPE REAL variables are DOUBLE PRECISION -C -C X(*),RNORME, The array X(*) contains the solution parameters -C RNORML if the integer output flag MODE = 0 or 1. -C The definition of MODE is given directly below. -C When MODE = 0 or 1, RNORME and RNORML -C respectively contain the residual vector -C Euclidean lengths of F - EX and B - AX. When -C MODE=1 the equality constraint equations EX=F -C are contradictory, so RNORME .NE. 0. The residual -C vector F-EX has minimal Euclidean length. For -C MODE .GE. 2, none of these parameters is defined. -C -C MODE Integer flag that indicates the subprogram -C status after completion. If MODE .GE. 2, no -C solution has been computed. -C -C MODE = -C -C 0 Both equality and inequality constraints -C are compatible and have been satisfied. -C -C 1 Equality constraints are contradictory. -C A generalized inverse solution of EX=F was used -C to minimize the residual vector length F-EX. -C In this sense, the solution is still meaningful. -C -C 2 Inequality constraints are contradictory. -C -C 3 Both equality and inequality constraints -C are contradictory. -C -C The following interpretation of -C MODE=1,2 or 3 must be made. The -C sets consisting of all solutions -C of the equality constraints EX=F -C and all vectors satisfying GX .GE. H -C have no points in common. (In -C particular this does not say that -C each individual set has no points -C at all, although this could be the -C case.) -C -C 4 Usage error occurred. The value -C of MDW is .LT. ME+MA+MG, MDW is -C .LT. N and a covariance matrix is -C requested, or the option vector -C PRGOPT(*) is not properly defined, -C or the lengths of the working arrays -C WS(*) and IP(*), when specified in -C IP(1) and IP(2) respectively, are not -C long enough. -C -C W(*,*) The array W(*,*) contains the N by N symmetric -C covariance matrix of the solution parameters, -C provided this was requested on input with -C the option vector PRGOPT(*) and the output -C flag is returned with MODE = 0 or 1. -C -C IP(*) The integer working array has three entries -C that provide rank and working array length -C information after completion. -C -C IP(1) = rank of equality constraint -C matrix. Define this quantity -C as KRANKE. -C -C IP(2) = rank of reduced least squares -C problem. -C -C IP(3) = the amount of storage in the -C working array WS(*) that was -C actually used by the subprogram. -C The formula given above for the length -C of WS(*) is a necessary overestimate. -C If exactly the same problem matrices -C are used in subsequent executions, -C the declared dimension of WS(*) can -C be reduced to this output value. -C User Designated -C Working Arrays.. -C -C WS(*),IP(*) These are respectively type real -C and type integer working arrays. -C Their required minimal lengths are -C given above. -C -C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Report SAND77-0552, Sandia -C Laboratories, June 1978. -C K. H. Haskell and R. J. Hanson, Selected algorithms for -C the linearly constrained least squares problem - a -C users guide, Report SAND78-1290, Sandia Laboratories, -C August 1979. -C K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Mathematical Programming -C 21 (1981), pp. 98-118. -C R. J. Hanson and K. H. Haskell, Two algorithms for the -C linearly constrained least squares problem, ACM -C Transactions on Mathematical Software, September 1982. -C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, -C DNRM2, DSCAL, DSWAP, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and extensively revised (WRB & RWC) -C 890831 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 900604 DP version created from SP version. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Removed prints and replaced DP --> DOUBLE PRECISION. (THC) -C***END PROLOGUE DLSEI - - INTEGER IP(3), MA, MDW, ME, MG, MODE, N - DOUBLE PRECISION PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*) -C - EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, DNRM2, - * DSCAL, DSWAP - DOUBLE PRECISION D1MACH, DASUM, DDOT, DNRM2 -C - DOUBLE PRECISION DRELPR, ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, - * SN, SNMAX, T, TAU, UJ, UP, VJ, XNORM, XNRME - INTEGER I, IMAX, J, JP1, K, KEY, KRANKE, LAST, LCHK, LINK, M, - * MAPKE1, MDEQC, MEND, MEP1, N1, N2, NEXT, NLINK, NOPT, NP1, - * NTIMES - LOGICAL COV, FIRST -C CHARACTER*8 XERN1, XERN2, XERN3, XERN4 - SAVE FIRST, DRELPR -C - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DLSEI -C -C Set the nominal tolerance used in the code for the equality -C constraint equations. -C - IF (FIRST) DRELPR = D1MACH(4) - FIRST = .FALSE. - TAU = SQRT(DRELPR) -C -C Check that enough storage was allocated in WS(*) and IP(*). -C - MODE = 4 - IF (MIN(N,ME,MA,MG) .LT. 0) THEN -C WRITE (XERN1, '(I8)') N -C WRITE (XERN2, '(I8)') ME -C WRITE (XERN3, '(I8)') MA -C WRITE (XERN4, '(I8)') MG -C CALL XERMSG ('SLATEC', 'LSEI', 'ALL OF THE VARIABLES N, ME,' // -C * ' MA, MG MUST BE .GE. 0$$ENTERED ROUTINE WITH' // -C * '$$N = ' // XERN1 // -C * '$$ME = ' // XERN2 // -C * '$$MA = ' // XERN3 // -C * '$$MG = ' // XERN4, 2, 1) - RETURN - ENDIF -C - IF (IP(1).GT.0) THEN - LCHK = 2*(ME+N) + MAX(MA+MG,N) + (MG+2)*(N+7) - IF (IP(1).LT.LCHK) THEN -C WRITE (XERN1, '(I8)') LCHK -C CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // -C * 'ALLOCATED FOR WS(*), NEED LW = ' // XERN1, 2, 1) - RETURN - ENDIF - ENDIF -C - IF (IP(2).GT.0) THEN - LCHK = MG + 2*N + 2 - IF (IP(2).LT.LCHK) THEN -C WRITE (XERN1, '(I8)') LCHK -C CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // -C * 'ALLOCATED FOR IP(*), NEED LIP = ' // XERN1, 2, 1) - RETURN - ENDIF - ENDIF -C -C Compute number of possible right multiplying Householder -C transformations. -C - M = ME + MA + MG - IF (N.LE.0 .OR. M.LE.0) THEN - MODE = 0 - RNORME = 0 - RNORML = 0 - RETURN - ENDIF -C - IF (MDW.LT.M) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', 'MDW.LT.ME+MA+MG IS AN ERROR', -C + 2, 1) - RETURN - ENDIF -C - NP1 = N + 1 - KRANKE = MIN(ME,N) - N1 = 2*KRANKE + 1 - N2 = N1 + N -C -C Set nominal values. -C -C The nominal column scaling used in the code is -C the identity scaling. -C - CALL DCOPY (N, 1.D0, 0, WS(N1), 1) -C -C No covariance matrix is nominally computed. -C - COV = .FALSE. -C -C Process option vector. -C Define bound for number of options to change. -C - NOPT = 1000 - NTIMES = 0 -C -C Define bound for positive values of LINK. -C - NLINK = 100000 - LAST = 1 - LINK = PRGOPT(1) - IF (LINK.EQ.0 .OR. LINK.GT.NLINK) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', -C + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) - RETURN - ENDIF -C - 100 IF (LINK.GT.1) THEN - NTIMES = NTIMES + 1 - IF (NTIMES.GT.NOPT) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', -C + 'THE LINKS IN THE OPTION VECTOR ARE CYCLING.', 2, 1) - RETURN - ENDIF -C - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.1) THEN - COV = PRGOPT(LAST+2) .NE. 0.D0 - ELSEIF (KEY.EQ.2 .AND. PRGOPT(LAST+2).NE.0.D0) THEN - DO 110 J = 1,N - T = DNRM2(M,W(1,J),1) - IF (T.NE.0.D0) T = 1.D0/T - WS(J+N1-1) = T - 110 CONTINUE - ELSEIF (KEY.EQ.3) THEN - CALL DCOPY (N, PRGOPT(LAST+2), 1, WS(N1), 1) - ELSEIF (KEY.EQ.4) THEN - TAU = MAX(DRELPR,PRGOPT(LAST+2)) - ENDIF -C - NEXT = PRGOPT(LINK) - IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', -C + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) - RETURN - ENDIF -C - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C - DO 120 J = 1,N - CALL DSCAL (M, WS(N1+J-1), W(1,J), 1) - 120 CONTINUE -C - IF (COV .AND. MDW.LT.N) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', -C + 'MDW .LT. N WHEN COV MATRIX NEEDED, IS AN ERROR', 2, 1) - RETURN - ENDIF -C -C Problem definition and option vector OK. -C - MODE = 0 -C -C Compute norm of equality constraint matrix and right side. -C - ENORM = 0.D0 - DO 130 J = 1,N - ENORM = MAX(ENORM,DASUM(ME,W(1,J),1)) - 130 CONTINUE -C - FNORM = DASUM(ME,W(1,NP1),1) - SNMAX = 0.D0 - RNMAX = 0.D0 - DO 150 I = 1,KRANKE -C -C Compute maximum ratio of vector lengths. Partition is at -C column I. -C - DO 140 K = I,ME - SN = DDOT(N-I+1,W(K,I),MDW,W(K,I),MDW) - RN = DDOT(I-1,W(K,1),MDW,W(K,1),MDW) - IF (RN.EQ.0.D0 .AND. SN.GT.SNMAX) THEN - SNMAX = SN - IMAX = K - ELSEIF (K.EQ.I .OR. SN*RNMAX.GT.RN*SNMAX) THEN - SNMAX = SN - RNMAX = RN - IMAX = K - ENDIF - 140 CONTINUE -C -C Interchange rows if necessary. -C - IF (I.NE.IMAX) CALL DSWAP (NP1, W(I,1), MDW, W(IMAX,1), MDW) - IF (SNMAX.GT.RNMAX*TAU**2) THEN -C -C Eliminate elements I+1,...,N in row I. -C - CALL DH12 (1, I, I+1, N, W(I,1), MDW, WS(I), W(I+1,1), MDW, - + 1, M-I) - ELSE - KRANKE = I - 1 - GO TO 160 - ENDIF - 150 CONTINUE -C -C Save diagonal terms of lower trapezoidal matrix. -C - 160 CALL DCOPY (KRANKE, W, MDW+1, WS(KRANKE+1), 1) -C -C Use Householder transformation from left to achieve -C KRANKE by KRANKE upper triangular form. -C - IF (KRANKE.LT.ME) THEN - DO 170 K = KRANKE,1,-1 -C -C Apply transformation to matrix cols. 1,...,K-1. -C - CALL DH12 (1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, - * K-1) -C -C Apply to rt side vector. -C - CALL DH12 (2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, - + 1, 1) - 170 CONTINUE - ENDIF -C -C Solve for variables 1,...,KRANKE in new coordinates. -C - CALL DCOPY (KRANKE, W(1, NP1), 1, X, 1) - DO 180 I = 1,KRANKE - X(I) = (X(I)-DDOT(I-1,W(I,1),MDW,X,1))/W(I,I) - 180 CONTINUE -C -C Compute residuals for reduced problem. -C - MEP1 = ME + 1 - RNORML = 0.D0 - DO 190 I = MEP1,M - W(I,NP1) = W(I,NP1) - DDOT(KRANKE,W(I,1),MDW,X,1) - SN = DDOT(KRANKE,W(I,1),MDW,W(I,1),MDW) - RN = DDOT(N-KRANKE,W(I,KRANKE+1),MDW,W(I,KRANKE+1),MDW) - IF (RN.LE.SN*TAU**2 .AND. KRANKE.LT.N) - * CALL DCOPY (N-KRANKE, 0.D0, 0, W(I,KRANKE+1), MDW) - 190 CONTINUE -C -C Compute equality constraint equations residual length. -C - RNORME = DNRM2(ME-KRANKE,W(KRANKE+1,NP1),1) -C -C Move reduced problem data upward if KRANKE.LT.ME. -C - IF (KRANKE.LT.ME) THEN - DO 200 J = 1,NP1 - CALL DCOPY (M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1) - 200 CONTINUE - ENDIF -C -C Compute solution of reduced problem. -C - CALL DLSI(W(KRANKE+1, KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT, - + X(KRANKE+1), RNORML, MODE, WS(N2), IP(2)) -C -C Test for consistency of equality constraints. -C - IF (ME.GT.0) THEN - MDEQC = 0 - XNRME = DASUM(KRANKE,W(1,NP1),1) - IF (RNORME.GT.TAU*(ENORM*XNRME+FNORM)) MDEQC = 1 - MODE = MODE + MDEQC -C -C Check if solution to equality constraints satisfies inequality -C constraints when there are no degrees of freedom left. -C - IF (KRANKE.EQ.N .AND. MG.GT.0) THEN - XNORM = DASUM(N,X,1) - MAPKE1 = MA + KRANKE + 1 - MEND = MA + KRANKE + MG - DO 210 I = MAPKE1,MEND - SIZE = DASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1)) - IF (W(I,NP1).GT.TAU*SIZE) THEN - MODE = MODE + 2 - GO TO 290 - ENDIF - 210 CONTINUE - ENDIF - ENDIF -C -C Replace diagonal terms of lower trapezoidal matrix. -C - IF (KRANKE.GT.0) THEN - CALL DCOPY (KRANKE, WS(KRANKE+1), 1, W, MDW+1) -C -C Reapply transformation to put solution in original coordinates. -C - DO 220 I = KRANKE,1,-1 - CALL DH12 (2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1) - 220 CONTINUE -C -C Compute covariance matrix of equality constrained problem. -C - IF (COV) THEN - DO 270 J = MIN(KRANKE,N-1),1,-1 - RB = WS(J)*W(J,J) - IF (RB.NE.0.D0) RB = 1.D0/RB - JP1 = J + 1 - DO 230 I = JP1,N - W(I,J) = RB*DDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW) - 230 CONTINUE -C - GAM = 0.5D0*RB*DDOT(N-J,W(JP1,J),1,W(J,JP1),MDW) - CALL DAXPY (N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1) - DO 250 I = JP1,N - DO 240 K = I,N - W(I,K) = W(I,K) + W(J,I)*W(K,J) + W(I,J)*W(J,K) - W(K,I) = W(I,K) - 240 CONTINUE - 250 CONTINUE - UJ = WS(J) - VJ = GAM*UJ - W(J,J) = UJ*VJ + UJ*VJ - DO 260 I = JP1,N - W(J,I) = UJ*W(I,J) + VJ*W(J,I) - 260 CONTINUE - CALL DCOPY (N-J, W(J, JP1), MDW, W(JP1,J), 1) - 270 CONTINUE - ENDIF - ENDIF -C -C Apply the scaling to the covariance matrix. -C - IF (COV) THEN - DO 280 I = 1,N - CALL DSCAL (N, WS(I+N1-1), W(I,1), MDW) - CALL DSCAL (N, WS(I+N1-1), W(1,I), 1) - 280 CONTINUE - ENDIF -C -C Rescale solution vector. -C - 290 IF (MODE.LE.1) THEN - DO 300 J = 1,N - X(J) = X(J)*WS(N1+J-1) - 300 CONTINUE - ENDIF -C - IP(1) = KRANKE - IP(3) = IP(3) + 2*KRANKE + N - RETURN - END -*DECK DLSI - SUBROUTINE DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, - + IP) -C***BEGIN PROLOGUE DLSI -C***SUBSIDIARY -C***PURPOSE Subsidiary to DLSEI -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (LSI-S, DLSI-D) -C***AUTHOR Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to DLSEI. The documentation for -C DLSEI has complete usage instructions. -C -C Solve.. -C AX = B, A MA by N (least squares equations) -C subject to.. -C -C GX.GE.H, G MG by N (inequality constraints) -C -C Input.. -C -C W(*,*) contains (A B) in rows 1,...,MA+MG, cols 1,...,N+1. -C (G H) -C -C MDW,MA,MG,N -C contain (resp) var. dimension of W(*,*), -C and matrix dimensions. -C -C PRGOPT(*), -C Program option vector. -C -C OUTPUT.. -C -C X(*),RNORM -C -C Solution vector(unless MODE=2), length of AX-B. -C -C MODE -C =0 Inequality constraints are compatible. -C =2 Inequality constraints contradictory. -C -C WS(*), -C Working storage of dimension K+N+(MG+2)*(N+7), -C where K=MAX(MA+MG,N). -C IP(MG+2*N+1) -C Integer working storage -C -C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, -C DLPDP, DSCAL, DSWAP -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and extensively revised (WRB & RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900604 DP version created from SP version. (RWC) -C 920422 Changed CALL to DHFTI to include variable MA. (WRB) -C***END PROLOGUE DLSI - - INTEGER IP(*), MA, MDW, MG, MODE, N - DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*) -C - EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, DLPDP, - * DSCAL, DSWAP - DOUBLE PRECISION D1MACH, DASUM, DDOT -C - DOUBLE PRECISION ANORM, DRELPR, FAC, GAM, RB, TAU, TOL, XNORM, - * TMP_NORM(1) - INTEGER I, J, K, KEY, KRANK, KRM1, KRP1, L, LAST, LINK, M, MAP1, - * MDLPDP, MINMAN, N1, N2, N3, NEXT, NP1 - LOGICAL COV, FIRST, SCLCOV -C - SAVE DRELPR, FIRST - DATA FIRST /.TRUE./ -C -C***FIRST EXECUTABLE STATEMENT DLSI -C -C Set the nominal tolerance used in the code. -C - IF (FIRST) DRELPR = D1MACH(4) - FIRST = .FALSE. - TOL = SQRT(DRELPR) -C - MODE = 0 - RNORM = 0.D0 - M = MA + MG - NP1 = N + 1 - KRANK = 0 - IF (N.LE.0 .OR. M.LE.0) GO TO 370 -C -C To process option vector. -C - COV = .FALSE. - SCLCOV = .TRUE. - LAST = 1 - LINK = PRGOPT(1) -C - 100 IF (LINK.GT.1) THEN - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.1) COV = PRGOPT(LAST+2) .NE. 0.D0 - IF (KEY.EQ.10) SCLCOV = PRGOPT(LAST+2) .EQ. 0.D0 - IF (KEY.EQ.5) TOL = MAX(DRELPR,PRGOPT(LAST+2)) - NEXT = PRGOPT(LINK) - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C -C Compute matrix norm of least squares equations. -C - ANORM = 0.D0 - DO 110 J = 1,N - ANORM = MAX(ANORM,DASUM(MA,W(1,J),1)) - 110 CONTINUE -C -C Set tolerance for DHFTI( ) rank test. -C - TAU = TOL*ANORM -C -C Compute Householder orthogonal decomposition of matrix. -C - CALL DCOPY (N, 0.D0, 0, WS, 1) - CALL DCOPY (MA, W(1, NP1), 1, WS, 1) - K = MAX(M,N) - MINMAN = MIN(MA,N) - N1 = K + 1 - N2 = N1 + N - CALL DHFTI (W, MDW, MA, N, WS, MA, 1, TAU, KRANK, TMP_NORM, - + WS(N2), WS(N1), IP) - RNORM = TMP_NORM(1) - FAC = 1.D0 - GAM = MA - KRANK - IF (KRANK.LT.MA .AND. SCLCOV) FAC = RNORM**2/GAM -C -C Reduce to DLPDP and solve. -C - MAP1 = MA + 1 -C -C Compute inequality rt-hand side for DLPDP. -C - IF (MA.LT.M) THEN - IF (MINMAN.GT.0) THEN - DO 120 I = MAP1,M - W(I,NP1) = W(I,NP1) - DDOT(N,W(I,1),MDW,WS,1) - 120 CONTINUE -C -C Apply permutations to col. of inequality constraint matrix. -C - DO 130 I = 1,MINMAN - CALL DSWAP (MG, W(MAP1,I), 1, W(MAP1,IP(I)), 1) - 130 CONTINUE -C -C Apply Householder transformations to constraint matrix. -C - IF (KRANK.GT.0 .AND. KRANK.LT.N) THEN - DO 140 I = KRANK,1,-1 - CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), - + W(MAP1,1), MDW, 1, MG) - 140 CONTINUE - ENDIF -C -C Compute permuted inequality constraint matrix times r-inv. -C - DO 160 I = MAP1,M - DO 150 J = 1,KRANK - W(I,J) = (W(I,J)-DDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J) - 150 CONTINUE - 160 CONTINUE - ENDIF -C -C Solve the reduced problem with DLPDP algorithm, -C the least projected distance problem. -C - CALL DLPDP(W(MAP1,1), MDW, MG, KRANK, N-KRANK, PRGOPT, X, - + XNORM, MDLPDP, WS(N2), IP(N+1)) -C -C Compute solution in original coordinates. -C - IF (MDLPDP.EQ.1) THEN - DO 170 I = KRANK,1,-1 - X(I) = (X(I)-DDOT(KRANK-I,W(I,I+1),MDW,X(I+1),1))/W(I,I) - 170 CONTINUE -C -C Apply Householder transformation to solution vector. -C - IF (KRANK.LT.N) THEN - DO 180 I = 1,KRANK - CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), - + X, 1, 1, 1) - 180 CONTINUE - ENDIF -C -C Repermute variables to their input order. -C - IF (MINMAN.GT.0) THEN - DO 190 I = MINMAN,1,-1 - CALL DSWAP (1, X(I), 1, X(IP(I)), 1) - 190 CONTINUE -C -C Variables are now in original coordinates. -C Add solution of unconstrained problem. -C - DO 200 I = 1,N - X(I) = X(I) + WS(I) - 200 CONTINUE -C -C Compute the residual vector norm. -C - RNORM = SQRT(RNORM**2+XNORM**2) - ENDIF - ELSE - MODE = 2 - ENDIF - ELSE - CALL DCOPY (N, WS, 1, X, 1) - ENDIF -C -C Compute covariance matrix based on the orthogonal decomposition -C from DHFTI( ). -C - IF (.NOT.COV .OR. KRANK.LE.0) GO TO 370 - KRM1 = KRANK - 1 - KRP1 = KRANK + 1 -C -C Copy diagonal terms to working array. -C - CALL DCOPY (KRANK, W, MDW+1, WS(N2), 1) -C -C Reciprocate diagonal terms. -C - DO 210 J = 1,KRANK - W(J,J) = 1.D0/W(J,J) - 210 CONTINUE -C -C Invert the upper triangular QR factor on itself. -C - IF (KRANK.GT.1) THEN - DO 230 I = 1,KRM1 - DO 220 J = I+1,KRANK - W(I,J) = -DDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J) - 220 CONTINUE - 230 CONTINUE - ENDIF -C -C Compute the inverted factor times its transpose. -C - DO 250 I = 1,KRANK - DO 240 J = I,KRANK - W(I,J) = DDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW) - 240 CONTINUE - 250 CONTINUE -C -C Zero out lower trapezoidal part. -C Copy upper triangular to lower triangular part. -C - IF (KRANK.LT.N) THEN - DO 260 J = 1,KRANK - CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) - 260 CONTINUE -C - DO 270 I = KRP1,N - CALL DCOPY (I, 0.D0, 0, W(I,1), MDW) - 270 CONTINUE -C -C Apply right side transformations to lower triangle. -C - N3 = N2 + KRP1 - DO 330 I = 1,KRANK - L = N1 + I - K = N2 + I - RB = WS(L-1)*WS(K-1) -C -C If RB.GE.0.D0, transformation can be regarded as zero. -C - IF (RB.LT.0.D0) THEN - RB = 1.D0/RB -C -C Store unscaled rank one Householder update in work array. -C - CALL DCOPY (N, 0.D0, 0, WS(N3), 1) - L = N1 + I - K = N3 + I - WS(K-1) = WS(L-1) -C - DO 280 J = KRP1,N - WS(N3+J-1) = W(I,J) - 280 CONTINUE -C - DO 290 J = 1,N - WS(J) = RB*(DDOT(J-I,W(J,I),MDW,WS(N3+I-1),1)+ - + DDOT(N-J+1,W(J,J),1,WS(N3+J-1),1)) - 290 CONTINUE -C - L = N3 + I - GAM = 0.5D0*RB*DDOT(N-I+1,WS(L-1),1,WS(I),1) - CALL DAXPY (N-I+1, GAM, WS(L-1), 1, WS(I), 1) - DO 320 J = I,N - DO 300 L = 1,I-1 - W(J,L) = W(J,L) + WS(N3+J-1)*WS(L) - 300 CONTINUE -C - DO 310 L = I,J - W(J,L) = W(J,L) + WS(J)*WS(N3+L-1)+WS(L)*WS(N3+J-1) - 310 CONTINUE - 320 CONTINUE - ENDIF - 330 CONTINUE -C -C Copy lower triangle to upper triangle to symmetrize the -C covariance matrix. -C - DO 340 I = 1,N - CALL DCOPY (I, W(I,1), MDW, W(1,I), 1) - 340 CONTINUE - ENDIF -C -C Repermute rows and columns. -C - DO 350 I = MINMAN,1,-1 - K = IP(I) - IF (I.NE.K) THEN - CALL DSWAP (1, W(I,I), 1, W(K,K), 1) - CALL DSWAP (I-1, W(1,I), 1, W(1,K), 1) - CALL DSWAP (K-I-1, W(I,I+1), MDW, W(I+1,K), 1) - CALL DSWAP (N-K, W(I, K+1), MDW, W(K, K+1), MDW) - ENDIF - 350 CONTINUE -C -C Put in normalized residual sum of squares scale factor -C and symmetrize the resulting covariance matrix. -C - DO 360 J = 1,N - CALL DSCAL (J, FAC, W(1,J), 1) - CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) - 360 CONTINUE -C - 370 IP(1) = KRANK - IP(2) = N + MAX(M,N) + (MG+2)*(N+7) - RETURN - END -*DECK D1MACH - DOUBLE PRECISION FUNCTION D1MACH (I) -C***BEGIN PROLOGUE D1MACH -C***PURPOSE Return floating point machine dependent constants. -C***LIBRARY SLATEC -C***CATEGORY R1 -C***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR Fox, P. A., (Bell Labs) -C Hall, A. D., (Bell Labs) -C Schryer, N. L., (Bell Labs) -C***DESCRIPTION -C -C D1MACH can be used to obtain machine-dependent parameters for the -C local machine environment. It is a function subprogram with one -C (input) argument, and can be referenced as follows: -C -C D = D1MACH(I) -C -C where I=1,...,5. The (output) value of D above is determined by -C the (input) value of I. The results for various values of I are -C discussed below. -C -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 Assume double precision numbers are represented in the T-digit, -C base-B form -C -C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C -C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and -C EMIN .LE. E .LE. EMAX. -C -C The values of B, T, EMIN and EMAX are provided in I1MACH as -C follows: -C I1MACH(10) = B, the base. -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 -C To alter this function for a particular environment, the desired -C set of DATA statements should be activated by removing the C from -C column 1. Also, the values of D1MACH(1) - D1MACH(4) should be -C checked for consistency with the local operating system. -C -C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for -C a portable library, ACM Transactions on Mathematical -C Software 4, 2 (June 1978), pp. 177-188. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 890213 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900618 Added DEC RISC constants. (WRB) -C 900723 Added IBM RS 6000 constants. (WRB) -C 900911 Added SUN 386i constants. (WRB) -C 910710 Added HP 730 constants. (SMR) -C 911114 Added Convex IEEE constants. (WRB) -C 920121 Added SUN -r8 compiler option constants. (WRB) -C 920229 Added Touchstone Delta i860 constants. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920625 Added CONVEX -p8 and -pd8 compiler option constants. -C (BKS, WRB) -C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) -C 010817 Elevated IEEE to highest importance; see next set of -C comments below. (DWL) -C***END PROLOGUE D1MACH -C - - INTEGER SMALL(4) - INTEGER LARGE(4) - INTEGER RIGHT(4) - INTEGER DIVER(4) - INTEGER LOG10(4) -C -C Initial data here correspond to the IEEE standard. The values for -C DMACH(1), DMACH(3) and DMACH(4) are slight upper bounds. The value -C for DMACH(2) is a slight lower bound. The value for DMACH(5) is -C a 20-digit approximation. If one of the sets of initial data below -C is preferred, do the necessary commenting and uncommenting. (DWL) - DOUBLE PRECISION DMACH(5) - DATA DMACH / 2.23D-308, 1.79D+308, 1.111D-16, 2.222D-16, - 1 0.30102999566398119521D0 / - SAVE DMACH -C - 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 AMIGA -C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE APOLLO -C -C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / -C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / -C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / -C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM -C -C DATA SMALL(1) / ZC00800000 / -C DATA SMALL(2) / Z000000000 / -C DATA LARGE(1) / ZDFFFFFFFF / -C DATA LARGE(2) / ZFFFFFFFFF / -C DATA RIGHT(1) / ZCC5800000 / -C DATA RIGHT(2) / Z000000000 / -C DATA DIVER(1) / ZCC6800000 / -C DATA DIVER(2) / Z000000000 / -C DATA LOG10(1) / ZD00E730E7 / -C DATA LOG10(2) / ZC77800DC0 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM -C -C DATA SMALL(1) / O1771000000000000 / -C DATA SMALL(2) / O0000000000000000 / -C DATA LARGE(1) / O0777777777777777 / -C DATA LARGE(2) / O0007777777777777 / -C DATA RIGHT(1) / O1461000000000000 / -C DATA RIGHT(2) / O0000000000000000 / -C DATA DIVER(1) / O1451000000000000 / -C DATA DIVER(2) / O0000000000000000 / -C DATA LOG10(1) / O1157163034761674 / -C DATA LOG10(2) / O0006677466732724 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS -C -C DATA SMALL(1) / O1771000000000000 / -C DATA SMALL(2) / O7770000000000000 / -C DATA LARGE(1) / O0777777777777777 / -C DATA LARGE(2) / O7777777777777777 / -C DATA RIGHT(1) / O1461000000000000 / -C DATA RIGHT(2) / O0000000000000000 / -C DATA DIVER(1) / O1451000000000000 / -C DATA DIVER(2) / O0000000000000000 / -C DATA LOG10(1) / O1157163034761674 / -C DATA LOG10(2) / O0006677466732724 / -C -C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE -C -C DATA SMALL(1) / Z"3001800000000000" / -C DATA SMALL(2) / Z"3001000000000000" / -C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / -C DATA LARGE(2) / Z"4FFE000000000000" / -C DATA RIGHT(1) / Z"3FD2800000000000" / -C DATA RIGHT(2) / Z"3FD2000000000000" / -C DATA DIVER(1) / Z"3FD3800000000000" / -C DATA DIVER(2) / Z"3FD3000000000000" / -C DATA LOG10(1) / Z"3FFF9A209A84FBCF" / -C DATA LOG10(2) / Z"3FFFF7988F8959AC" / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES -C -C DATA SMALL(1) / 00564000000000000000B / -C DATA SMALL(2) / 00000000000000000000B / -C DATA LARGE(1) / 37757777777777777777B / -C DATA LARGE(2) / 37157777777777777777B / -C DATA RIGHT(1) / 15624000000000000000B / -C DATA RIGHT(2) / 00000000000000000000B / -C DATA DIVER(1) / 15634000000000000000B / -C DATA DIVER(2) / 00000000000000000000B / -C DATA LOG10(1) / 17164642023241175717B / -C DATA LOG10(2) / 16367571421742254654B / -C -C MACHINE CONSTANTS FOR THE CELERITY C1260 -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fn OR -pd8 COMPILER OPTION -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CC0000000000000' / -C DATA DMACH(4) / Z'3CD0000000000000' / -C DATA DMACH(5) / Z'3FF34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fi COMPILER OPTION -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -p8 COMPILER OPTION -C -C DATA DMACH(1) / Z'00010000000000000000000000000000' / -C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3F900000000000000000000000000000' / -C DATA DMACH(4) / Z'3F910000000000000000000000000000' / -C DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / -C -C MACHINE CONSTANTS FOR THE CRAY -C -C DATA SMALL(1) / 201354000000000000000B / -C DATA SMALL(2) / 000000000000000000000B / -C DATA LARGE(1) / 577767777777777777777B / -C DATA LARGE(2) / 000007777777777777774B / -C DATA RIGHT(1) / 376434000000000000000B / -C DATA RIGHT(2) / 000000000000000000000B / -C DATA DIVER(1) / 376444000000000000000B / -C DATA DIVER(2) / 000000000000000000000B / -C DATA LOG10(1) / 377774642023241175717B / -C DATA LOG10(2) / 000007571421742254654B / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - -C STATIC DMACH(5) -C -C DATA SMALL / 20K, 3*0 / -C DATA LARGE / 77777K, 3*177777K / -C DATA RIGHT / 31420K, 3*0 / -C DATA DIVER / 32020K, 3*0 / -C DATA LOG10 / 40423K, 42023K, 50237K, 74776K / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING G_FLOAT -C -C DATA DMACH(1) / '0000000000000010'X / -C DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / -C DATA DMACH(3) / '0000000000003CC0'X / -C DATA DMACH(4) / '0000000000003CD0'X / -C DATA DMACH(5) / '79FF509F44133FF3'X / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING IEEE_FORMAT -C -C DATA DMACH(1) / '0010000000000000'X / -C DATA DMACH(2) / '7FEFFFFFFFFFFFFF'X / -C DATA DMACH(3) / '3CA0000000000000'X / -C DATA DMACH(4) / '3CB0000000000000'X / -C DATA DMACH(5) / '3FD34413509F79FF'X / -C -C MACHINE CONSTANTS FOR THE DEC RISC -C -C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ -C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ -C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ -C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ -C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING D_FLOATING -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS -C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS -C -C DATA SMALL(1), SMALL(2) / 128, 0 / -C DATA LARGE(1), LARGE(2) / -32769, -1 / -C DATA RIGHT(1), RIGHT(2) / 9344, 0 / -C DATA DIVER(1), DIVER(2) / 9472, 0 / -C DATA LOG10(1), LOG10(2) / 546979738, -805796613 / -C -C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / -C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING G_FLOATING -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS -C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS -C -C DATA SMALL(1), SMALL(2) / 16, 0 / -C DATA LARGE(1), LARGE(2) / -32769, -1 / -C DATA RIGHT(1), RIGHT(2) / 15552, 0 / -C DATA DIVER(1), DIVER(2) / 15568, 0 / -C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / -C -C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / -C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / -C -C MACHINE CONSTANTS FOR THE ELXSI 6400 -C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) -C -C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / -C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / -C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / -C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / -C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C -C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / -C DATA LARGE(1), LARGE(2) / '37777777, '37777577 / -C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / -C DATA DIVER(1), DIVER(2) / '20000000, '00000334 / -C DATA LOG10(1), LOG10(2) / '23210115, '10237777 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES -C -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 / -C -C MACHINE CONSTANTS FOR THE HP 730 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / -C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / -C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / -C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / -C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA SMALL(1), SMALL(2) / 40000B, 0 / -C DATA SMALL(3), SMALL(4) / 0, 1 / -C DATA LARGE(1), LARGE(2) / 77777B, 177777B / -C DATA LARGE(3), LARGE(4) / 177777B, 177776B / -C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / -C DATA RIGHT(3), RIGHT(4) / 0, 225B / -C DATA DIVER(1), DIVER(2) / 40000B, 0 / -C DATA DIVER(3), DIVER(4) / 0, 227B / -C DATA LOG10(1), LOG10(2) / 46420B, 46502B / -C DATA LOG10(3), LOG10(4) / 76747B, 176377B / -C -C MACHINE CONSTANTS FOR THE HP 9000 -C -C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / -C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / -C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / -C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / -C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND -C THE PERKIN ELMER (INTERDATA) 7/32. -C -C DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / -C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / -C -C MACHINE CONSTANTS FOR THE IBM PC -C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION -C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. -C -C DATA SMALL(1) / 2.23D-308 / -C DATA LARGE(1) / 1.79D+308 / -C DATA RIGHT(1) / 1.11D-16 / -C DATA DIVER(1) / 2.22D-16 / -C DATA LOG10(1) / 0.301029995663981195D0 / -C -C MACHINE CONSTANTS FOR THE IBM RS 6000 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE INTEL i860 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) -C -C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / -C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / -C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / -C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / -C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) -C -C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / -C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / -C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / -C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / -C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -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 / -C -C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / -C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / -C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / -C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / -C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA SMALL(1), SMALL(2) / 128, 0 / -C DATA SMALL(3), SMALL(4) / 0, 0 / -C DATA LARGE(1), LARGE(2) / 32767, -1 / -C DATA LARGE(3), LARGE(4) / -1, -1 / -C DATA RIGHT(1), RIGHT(2) / 9344, 0 / -C DATA RIGHT(3), RIGHT(4) / 0, 0 / -C DATA DIVER(1), DIVER(2) / 9472, 0 / -C DATA DIVER(3), DIVER(4) / 0, 0 / -C DATA LOG10(1), LOG10(2) / 16282, 8346 / -C DATA LOG10(3), LOG10(4) / -31493, -12296 / -C -C DATA SMALL(1), SMALL(2) / O000200, O000000 / -C DATA SMALL(3), SMALL(4) / O000000, O000000 / -C DATA LARGE(1), LARGE(2) / O077777, O177777 / -C DATA LARGE(3), LARGE(4) / O177777, O177777 / -C DATA RIGHT(1), RIGHT(2) / O022200, O000000 / -C DATA RIGHT(3), RIGHT(4) / O000000, O000000 / -C DATA DIVER(1), DIVER(2) / O022400, O000000 / -C DATA DIVER(3), DIVER(4) / O000000, O000000 / -C DATA LOG10(1), LOG10(2) / O037632, O020232 / -C DATA LOG10(3), LOG10(4) / O102373, O147770 / -C -C MACHINE CONSTANTS FOR THE SILICON GRAPHICS -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE SUN -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE SUN -C USING THE -r8 COMPILER OPTION -C -C DATA DMACH(1) / Z'00010000000000000000000000000000' / -C DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / -C DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / -C DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / -C -C MACHINE CONSTANTS FOR THE SUN 386i -C -C DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / -C DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / -C DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' -C DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER -C -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 / -C -C***FIRST EXECUTABLE STATEMENT D1MACH -C IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'D1MACH', -C + 'I OUT OF BOUNDS', 1, 2) -C - D1MACH = DMACH(I) - RETURN -C - END -*DECK I1MACH - INTEGER FUNCTION I1MACH (I) -C***BEGIN PROLOGUE I1MACH -C***PURPOSE Return integer machine dependent constants. -C***LIBRARY SLATEC -C***CATEGORY R1 -C***TYPE INTEGER (I1MACH-I) -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR Fox, P. A., (Bell Labs) -C Hall, A. D., (Bell Labs) -C Schryer, N. L., (Bell Labs) -C***DESCRIPTION -C -C I1MACH can be used to obtain machine-dependent parameters for the -C local machine environment. It is a function subprogram with one -C (input) argument and can be referenced as follows: -C -C K = I1MACH(I) -C -C where I=1,...,16. The (output) value of K above is determined by -C the (input) value of I. The results for various values of I are -C discussed below. -C -C I/O unit numbers: -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 -C Words: -C I1MACH( 5) = the number of bits per integer storage unit. -C I1MACH( 6) = the number of characters per integer storage unit. -C -C Integers: -C assume integers are represented in the S-digit, base-A form -C -C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) -C -C where 0 .LE. X(I) .LT. A for I=0,...,S-1. -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 -C Floating-Point Numbers: -C Assume floating-point numbers are represented in the T-digit, -C base-B form -C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C -C where 0 .LE. X(I) .LT. B for I=1,...,T, -C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. -C I1MACH(10) = B, the base. -C -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 -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 -C To alter this function for a particular environment, the desired -C set of DATA statements should be activated by removing the C from -C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be -C checked for consistency with the local operating system. -C -C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for -C a portable library, ACM Transactions on Mathematical -C Software 4, 2 (June 1978), pp. 177-188. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 891012 Added VAX G-floating constants. (WRB) -C 891012 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900618 Added DEC RISC constants. (WRB) -C 900723 Added IBM RS 6000 constants. (WRB) -C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. -C (RWC) -C 910710 Added HP 730 constants. (SMR) -C 911114 Added Convex IEEE constants. (WRB) -C 920121 Added SUN -r8 compiler option constants. (WRB) -C 920229 Added Touchstone Delta i860 constants. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920625 Added Convex -p8 and -pd8 compiler option constants. -C (BKS, WRB) -C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) -C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler -C options. (DWL, RWC and WRB). -C 010817 Elevated IEEE to highest importance; see next set of -C comments below. (DWL) -C***END PROLOGUE I1MACH -C -C Initial data here correspond to the IEEE standard. If one of the -C sets of initial data below is preferred, do the necessary commenting -C and uncommenting. (DWL) - INTEGER IMACH(16),OUTPUT - DATA IMACH( 1) / 5 / - DATA IMACH( 2) / 6 / - DATA IMACH( 3) / 6 / - DATA IMACH( 4) / 6 / - DATA IMACH( 5) / 32 / - DATA IMACH( 6) / 4 / - DATA IMACH( 7) / 2 / - DATA IMACH( 8) / 31 / - DATA IMACH( 9) / 2147483647 / - DATA IMACH(10) / 2 / - DATA IMACH(11) / 24 / - DATA IMACH(12) / -126 / - DATA IMACH(13) / 127 / - DATA IMACH(14) / 53 / - DATA IMACH(15) / -1022 / - DATA IMACH(16) / 1023 / - SAVE IMACH - EQUIVALENCE (IMACH(4),OUTPUT) -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT COMPILER -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE APOLLO -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 129 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1025 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM -C -C DATA IMACH( 1) / 7 / -C DATA IMACH( 2) / 2 / -C DATA IMACH( 3) / 2 / -C DATA IMACH( 4) / 2 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 33 / -C DATA IMACH( 9) / Z1FFFFFFFF / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -256 / -C DATA IMACH(13) / 255 / -C DATA IMACH(14) / 60 / -C DATA IMACH(15) / -256 / -C DATA IMACH(16) / 255 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM -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) / 48 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 39 / -C DATA IMACH( 9) / O0007777777777777 / -C DATA IMACH(10) / 8 / -C DATA IMACH(11) / 13 / -C DATA IMACH(12) / -50 / -C DATA IMACH(13) / 76 / -C DATA IMACH(14) / 26 / -C DATA IMACH(15) / -50 / -C DATA IMACH(16) / 76 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS -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) / 48 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 39 / -C DATA IMACH( 9) / O0007777777777777 / -C DATA IMACH(10) / 8 / -C DATA IMACH(11) / 13 / -C DATA IMACH(12) / -50 / -C DATA IMACH(13) / 76 / -C DATA IMACH(14) / 26 / -C DATA IMACH(15) / -32754 / -C DATA IMACH(16) / 32780 / -C -C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE -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) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -4095 / -C DATA IMACH(13) / 4094 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -4095 / -C DATA IMACH(16) / 4094 / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6LOUTPUT/ -C DATA IMACH( 5) / 60 / -C DATA IMACH( 6) / 10 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 48 / -C DATA IMACH( 9) / 00007777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -929 / -C DATA IMACH(13) / 1070 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -929 / -C DATA IMACH(16) / 1069 / -C -C MACHINE CONSTANTS FOR THE CELERITY C1260 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 0 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / Z'7FFFFFFF' / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fn COMPILER OPTION -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) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fi COMPILER OPTION -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -p8 COMPILER OPTION -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) / 64 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1023 / -C DATA IMACH(13) / 1023 / -C DATA IMACH(14) / 113 / -C DATA IMACH(15) / -16383 / -C DATA IMACH(16) / 16383 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -pd8 COMPILER OPTION -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) / 64 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1023 / -C DATA IMACH(13) / 1023 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CRAY -C USING THE 46 BIT INTEGER COMPILER OPTION -C -C DATA IMACH( 1) / 100 / -C DATA IMACH( 2) / 101 / -C DATA IMACH( 3) / 102 / -C DATA IMACH( 4) / 101 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 46 / -C DATA IMACH( 9) / 1777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -8189 / -C DATA IMACH(13) / 8190 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -8099 / -C DATA IMACH(16) / 8190 / -C -C MACHINE CONSTANTS FOR THE CRAY -C USING THE 64 BIT INTEGER COMPILER OPTION -C -C DATA IMACH( 1) / 100 / -C DATA IMACH( 2) / 101 / -C DATA IMACH( 3) / 102 / -C DATA IMACH( 4) / 101 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 777777777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -8189 / -C DATA IMACH(13) / 8190 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -8099 / -C DATA IMACH(16) / 8190 / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C -C DATA IMACH( 1) / 11 / -C DATA IMACH( 2) / 12 / -C DATA IMACH( 3) / 8 / -C DATA IMACH( 4) / 10 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING G_FLOAT -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING IEEE_FLOAT -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE DEC RISC -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING D_FLOATING -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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 / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING G_FLOATING -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE ELXSI 6400 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 32 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 24 / -C DATA IMACH( 6) / 3 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 23 / -C DATA IMACH( 9) / 8388607 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 38 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 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) / 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) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 63 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 730 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 4 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 39 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 4 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 55 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 9000 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 7 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 32 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1015 / -C DATA IMACH(16) / 1017 / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND -C THE PERKIN ELMER (INTERDATA) 7/32. -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) / Z7FFFFFFF / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 / -C -C MACHINE CONSTANTS FOR THE IBM PC -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 0 / -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) / -125 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE IBM RS 6000 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 0 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE INTEL i860 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 5 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / "377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 54 / -C DATA IMACH(15) / -101 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 5 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / "377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 62 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGER ARITHMETIC. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGER ARITHMETIC. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -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 / -C -C MACHINE CONSTANTS FOR THE SILICON GRAPHICS -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE SUN -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE SUN -C USING THE -r8 COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / 53 / -C DATA IMACH(12) / -1021 / -C DATA IMACH(13) / 1024 / -C DATA IMACH(14) / 113 / -C DATA IMACH(15) / -16381 / -C DATA IMACH(16) / 16384 / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 1 / -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) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 60 / -C DATA IMACH(15) / -1024 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR -C -C DATA IMACH( 1) / 1 / -C DATA IMACH( 2) / 1 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -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 / -C -C***FIRST EXECUTABLE STATEMENT I1MACH - IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 -C - I1MACH = IMACH(I) - RETURN -C - 10 CONTINUE - WRITE (UNIT = OUTPUT, FMT = 9000) - 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') -C -C CALL FDUMP -C - STOP - END -*DECK DH12 - SUBROUTINE DH12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV, - + NCV) -C***BEGIN PROLOGUE DH12 -C***SUBSIDIARY -C***PURPOSE Subsidiary to DHFTI, DLSEI and DWNNLS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (H12-S, DH12-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C *** DOUBLE PRECISION VERSION OF H12 ****** -C -C C.L.Lawson and R.J.Hanson, Jet Propulsion Laboratory, 1973 Jun 12 -C to appear in 'Solving Least Squares Problems', Prentice-Hall, 1974 -C -C Construction and/or application of a single -C Householder transformation.. Q = I + U*(U**T)/B -C -C MODE = 1 or 2 to select algorithm H1 or H2 . -C LPIVOT is the index of the pivot element. -C L1,M If L1 .LE. M the transformation will be constructed to -C zero elements indexed from L1 through M. If L1 GT. M -C THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. -C U(),IUE,UP On entry to H1 U() contains the pivot vector. -C IUE is the storage increment between elements. -C On exit from H1 U() and UP -C contain quantities defining the vector U of the -C Householder transformation. On entry to H2 U() -C and UP should contain quantities previously computed -C by H1. These will not be modified by H2. -C C() On entry to H1 or H2 C() contains a matrix which will be -C regarded as a set of vectors to which the Householder -C transformation is to be applied. On exit C() contains the -C set of transformed vectors. -C ICE Storage increment between elements of vectors in C(). -C ICV Storage increment between vectors in C(). -C NCV Number of vectors in C() to be transformed. If NCV .LE. 0 -C no operations will be done on C(). -C -C***SEE ALSO DHFTI, DLSEI, DWNNLS -C***ROUTINES CALLED DAXPY, DDOT, DSWAP -C***REVISION HISTORY (YYMMDD) -C 790101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900911 Added DDOT to DOUBLE PRECISION statement. (WRB) -C***END PROLOGUE DH12 - - INTEGER I, I2, I3, I4, ICE, ICV, INCR, IUE, J, KL1, KL2, KLP, - * L1, L1M1, LPIVOT, M, MML1P2, MODE, NCV - DOUBLE PRECISION B, C, CL, CLINV, ONE, UL1M1, SM, U, UP, DDOT - DIMENSION U(IUE,*), C(*) -C BEGIN BLOCK PERMITTING ...EXITS TO 140 -C***FIRST EXECUTABLE STATEMENT DH12 - ONE = 1.0D0 -C -C ...EXIT - IF (0 .GE. LPIVOT .OR. LPIVOT .GE. L1 .OR. L1 .GT. M) GO TO 140 - CL = ABS(U(1,LPIVOT)) - IF (MODE .EQ. 2) GO TO 40 -C ****** CONSTRUCT THE TRANSFORMATION. ****** - DO 10 J = L1, M - CL = MAX(ABS(U(1,J)),CL) - 10 CONTINUE - IF (CL .GT. 0.0D0) GO TO 20 -C .........EXIT - GO TO 140 - 20 CONTINUE - CLINV = ONE/CL - SM = (U(1,LPIVOT)*CLINV)**2 - DO 30 J = L1, M - SM = SM + (U(1,J)*CLINV)**2 - 30 CONTINUE - CL = CL*SQRT(SM) - IF (U(1,LPIVOT) .GT. 0.0D0) CL = -CL - UP = U(1,LPIVOT) - CL - U(1,LPIVOT) = CL - GO TO 50 - 40 CONTINUE -C ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** -C - IF (CL .GT. 0.0D0) GO TO 50 -C ......EXIT - GO TO 140 - 50 CONTINUE -C ...EXIT - IF (NCV .LE. 0) GO TO 140 - B = UP*U(1,LPIVOT) -C B MUST BE NONPOSITIVE HERE. IF B = 0., RETURN. -C - IF (B .LT. 0.0D0) GO TO 60 -C ......EXIT - GO TO 140 - 60 CONTINUE - B = ONE/B - MML1P2 = M - L1 + 2 - IF (MML1P2 .LE. 20) GO TO 80 - L1M1 = L1 - 1 - KL1 = 1 + (L1M1 - 1)*ICE - KL2 = KL1 - KLP = 1 + (LPIVOT - 1)*ICE - UL1M1 = U(1,L1M1) - U(1,L1M1) = UP - IF (LPIVOT .NE. L1M1) CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) - DO 70 J = 1, NCV - SM = DDOT(MML1P2,U(1,L1M1),IUE,C(KL1),ICE) - SM = SM*B - CALL DAXPY(MML1P2,SM,U(1,L1M1),IUE,C(KL1),ICE) - KL1 = KL1 + ICV - 70 CONTINUE - U(1,L1M1) = UL1M1 -C ......EXIT - IF (LPIVOT .EQ. L1M1) GO TO 140 - KL1 = KL2 - CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) - GO TO 130 - 80 CONTINUE - I2 = 1 - ICV + ICE*(LPIVOT - 1) - INCR = ICE*(L1 - LPIVOT) - DO 120 J = 1, NCV - I2 = I2 + ICV - I3 = I2 + INCR - I4 = I3 - SM = C(I2)*UP - DO 90 I = L1, M - SM = SM + C(I3)*U(1,I) - I3 = I3 + ICE - 90 CONTINUE - IF (SM .EQ. 0.0D0) GO TO 110 - SM = SM*B - C(I2) = C(I2) + SM*UP - DO 100 I = L1, M - C(I4) = C(I4) + SM*U(1,I) - I4 = I4 + ICE - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - 130 CONTINUE - 140 CONTINUE - RETURN - END -*DECK DHFTI - SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, - + G, IP) -C***BEGIN PROLOGUE DHFTI -C***PURPOSE Solve a least squares problem for banded matrices using -C sequential accumulation of rows of the data matrix. -C Exactly one right-hand side vector is permitted. -C***LIBRARY SLATEC -C***CATEGORY D9 -C***TYPE DOUBLE PRECISION (HFTI-S, DHFTI-D) -C***KEYWORDS CURVE FITTING, LEAST SQUARES -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DIMENSION A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N) -C -C This subroutine solves a linear least squares problem or a set of -C linear least squares problems having the same matrix but different -C right-side vectors. The problem data consists of an M by N matrix -C A, an M by NB matrix B, and an absolute tolerance parameter TAU -C whose usage is described below. The NB column vectors of B -C represent right-side vectors for NB distinct linear least squares -C problems. -C -C This set of problems can also be written as the matrix least -C squares problem -C -C AX = B, -C -C where X is the N by NB solution matrix. -C -C Note that if B is the M by M identity matrix, then X will be the -C pseudo-inverse of A. -C -C This subroutine first transforms the augmented matrix (A B) to a -C matrix (R C) using premultiplying Householder transformations with -C column interchanges. All subdiagonal elements in the matrix R are -C zero and its diagonal elements satisfy -C -C ABS(R(I,I)).GE.ABS(R(I+1,I+1)), -C -C I = 1,...,L-1, where -C -C L = MIN(M,N). -C -C The subroutine will compute an integer, KRANK, equal to the number -C of diagonal terms of R that exceed TAU in magnitude. Then a -C solution of minimum Euclidean length is computed using the first -C KRANK rows of (R C). -C -C To be specific we suggest that the user consider an easily -C computable matrix norm, such as, the maximum of all column sums of -C magnitudes. -C -C Now if the relative uncertainty of B is EPS, (norm of uncertainty/ -C norm of B), it is suggested that TAU be set approximately equal to -C EPS*(norm of A). -C -C The user must dimension all arrays appearing in the call list.. -C A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N). This -C permits the solution of a range of problems in the same array -C space. -C -C The entire set of parameters for DHFTI are -C -C INPUT.. All TYPE REAL variables are DOUBLE PRECISION -C -C A(*,*),MDA,M,N The array A(*,*) initially contains the M by N -C matrix A of the least squares problem AX = B. -C The first dimensioning parameter of the array -C A(*,*) is MDA, which must satisfy MDA.GE.M -C Either M.GE.N or M.LT.N is permitted. There -C is no restriction on the rank of A. The -C condition MDA.LT.M is considered an error. -C -C B(*),MDB,NB If NB = 0 the subroutine will perform the -C orthogonal decomposition but will make no -C references to the array B(*). If NB.GT.0 -C the array B(*) must initially contain the M by -C NB matrix B of the least squares problem AX = -C B. If NB.GE.2 the array B(*) must be doubly -C subscripted with first dimensioning parameter -C MDB.GE.MAX(M,N). If NB = 1 the array B(*) may -C be either doubly or singly subscripted. In -C the latter case the value of MDB is arbitrary -C but it should be set to some valid integer -C value such as MDB = M. -C -C The condition of NB.GT.1.AND.MDB.LT. MAX(M,N) -C is considered an error. -C -C TAU Absolute tolerance parameter provided by user -C for pseudorank determination. -C -C H(*),G(*),IP(*) Arrays of working space used by DHFTI. -C -C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION -C -C A(*,*) The contents of the array A(*,*) will be -C modified by the subroutine. These contents -C are not generally required by the user. -C -C B(*) On return the array B(*) will contain the N by -C NB solution matrix X. -C -C KRANK Set by the subroutine to indicate the -C pseudorank of A. -C -C RNORM(*) On return, RNORM(J) will contain the Euclidean -C norm of the residual vector for the problem -C defined by the J-th column vector of the array -C B(*,*) for J = 1,...,NB. -C -C H(*),G(*) On return these arrays respectively contain -C elements of the pre- and post-multiplying -C Householder transformations used to compute -C the minimum Euclidean length solution. -C -C IP(*) Array in which the subroutine records indices -C describing the permutation of column vectors. -C The contents of arrays H(*),G(*) and IP(*) -C are not generally required by the user. -C -C***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares -C Problems, Prentice-Hall, Inc., 1974, Chapter 14. -C***ROUTINES CALLED D1MACH, DH12, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891006 Cosmetic changes to prologue. (WRB) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 901005 Replace usage of DDIFF with usage of D1MACH. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DHFTI - - INTEGER I, II, IOPT, IP(*), IP1, J, JB, JJ, K, KP1, KRANK, L, - * LDIAG, LMAX, M, MDA, MDB, N, NB, NERR - DOUBLE PRECISION A, B, D1MACH, DZERO, FACTOR, - * G, H, HMAX, RELEPS, RNORM, SM, SM1, SZERO, TAU, TMP - DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*) - SAVE RELEPS - DATA RELEPS /0.D0/ -C BEGIN BLOCK PERMITTING ...EXITS TO 360 -C***FIRST EXECUTABLE STATEMENT DHFTI - IF (RELEPS.EQ.0.D0) RELEPS = D1MACH(4) - SZERO = 0.0D0 - DZERO = 0.0D0 - FACTOR = 0.001D0 -C - K = 0 - LDIAG = MIN(M,N) - IF (LDIAG .LE. 0) GO TO 350 -C BEGIN BLOCK PERMITTING ...EXITS TO 130 -C BEGIN BLOCK PERMITTING ...EXITS TO 120 - IF (MDA .GE. M) GO TO 10 - NERR = 1 - IOPT = 2 -C CALL XERMSG ('SLATEC', 'DHFTI', -C + 'MDA.LT.M, PROBABLE ERROR.', -C + NERR, IOPT) -C ...............EXIT - GO TO 360 - 10 CONTINUE -C - IF (NB .LE. 1 .OR. MAX(M,N) .LE. MDB) GO TO 20 - NERR = 2 - IOPT = 2 -C CALL XERMSG ('SLATEC', 'DHFTI', -C + 'MDB.LT.MAX(M,N).AND.NB.GT.1. PROBABLE ERROR.', -C + NERR, IOPT) -C ...............EXIT - GO TO 360 - 20 CONTINUE -C - DO 100 J = 1, LDIAG -C BEGIN BLOCK PERMITTING ...EXITS TO 70 - IF (J .EQ. 1) GO TO 40 -C -C UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX -C .. - LMAX = J - DO 30 L = J, N - H(L) = H(L) - A(J-1,L)**2 - IF (H(L) .GT. H(LMAX)) LMAX = L - 30 CONTINUE -C ......EXIT - IF (FACTOR*H(LMAX) .GT. HMAX*RELEPS) GO TO 70 - 40 CONTINUE -C -C COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX -C .. - LMAX = J - DO 60 L = J, N - H(L) = 0.0D0 - DO 50 I = J, M - H(L) = H(L) + A(I,L)**2 - 50 CONTINUE - IF (H(L) .GT. H(LMAX)) LMAX = L - 60 CONTINUE - HMAX = H(LMAX) - 70 CONTINUE -C .. -C LMAX HAS BEEN DETERMINED -C -C DO COLUMN INTERCHANGES IF NEEDED. -C .. - IP(J) = LMAX - IF (IP(J) .EQ. J) GO TO 90 - DO 80 I = 1, M - TMP = A(I,J) - A(I,J) = A(I,LMAX) - A(I,LMAX) = TMP - 80 CONTINUE - H(LMAX) = H(J) - 90 CONTINUE -C -C COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A -C AND B. -C .. - CALL DH12(1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA, - * N-J) - CALL DH12(2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB) - 100 CONTINUE -C -C DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, -C TAU. -C .. - DO 110 J = 1, LDIAG -C ......EXIT - IF (ABS(A(J,J)) .LE. TAU) GO TO 120 - 110 CONTINUE - K = LDIAG -C ......EXIT - GO TO 130 - 120 CONTINUE - K = J - 1 - 130 CONTINUE - KP1 = K + 1 -C -C COMPUTE THE NORMS OF THE RESIDUAL VECTORS. -C - IF (NB .LT. 1) GO TO 170 - DO 160 JB = 1, NB - TMP = SZERO - IF (M .LT. KP1) GO TO 150 - DO 140 I = KP1, M - TMP = TMP + B(I,JB)**2 - 140 CONTINUE - 150 CONTINUE - RNORM(JB) = SQRT(TMP) - 160 CONTINUE - 170 CONTINUE -C SPECIAL FOR PSEUDORANK = 0 - IF (K .GT. 0) GO TO 210 - IF (NB .LT. 1) GO TO 200 - DO 190 JB = 1, NB - DO 180 I = 1, N - B(I,JB) = SZERO - 180 CONTINUE - 190 CONTINUE - 200 CONTINUE - GO TO 340 - 210 CONTINUE -C -C IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER -C DECOMPOSITION OF FIRST K ROWS. -C .. - IF (K .EQ. N) GO TO 230 - DO 220 II = 1, K - I = KP1 - II - CALL DH12(1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1) - 220 CONTINUE - 230 CONTINUE -C -C - IF (NB .LT. 1) GO TO 330 - DO 320 JB = 1, NB -C -C SOLVE THE K BY K TRIANGULAR SYSTEM. -C .. - DO 260 L = 1, K - SM = DZERO - I = KP1 - L - IP1 = I + 1 - IF (K .LT. IP1) GO TO 250 - DO 240 J = IP1, K - SM = SM + A(I,J)*B(J,JB) - 240 CONTINUE - 250 CONTINUE - SM1 = SM - B(I,JB) = (B(I,JB) - SM1)/A(I,I) - 260 CONTINUE -C -C COMPLETE COMPUTATION OF SOLUTION VECTOR. -C .. - IF (K .EQ. N) GO TO 290 - DO 270 J = KP1, N - B(J,JB) = SZERO - 270 CONTINUE - DO 280 I = 1, K - CALL DH12(2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1, - * MDB,1) - 280 CONTINUE - 290 CONTINUE -C -C RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE -C COLUMN INTERCHANGES. -C .. - DO 310 JJ = 1, LDIAG - J = LDIAG + 1 - JJ - IF (IP(J) .EQ. J) GO TO 300 - L = IP(J) - TMP = B(L,JB) - B(L,JB) = B(J,JB) - B(J,JB) = TMP - 300 CONTINUE - 310 CONTINUE - 320 CONTINUE - 330 CONTINUE - 340 CONTINUE - 350 CONTINUE -C .. -C THE SOLUTION VECTORS, X, ARE NOW -C IN THE FIRST N ROWS OF THE ARRAY B(,). -C - KRANK = K - 360 CONTINUE - RETURN - END -*DECK DLPDP - SUBROUTINE DLPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, - + IS) -C***BEGIN PROLOGUE DLPDP -C***SUBSIDIARY -C***PURPOSE Subsidiary to DLSEI -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (LPDP-S, DLPDP-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C **** Double Precision version of LPDP **** -C DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1), -C where N=N1+N2. This is a slight overestimate for WS(*). -C -C Determine an N1-vector W, and -C an N2-vector Z -C which minimizes the Euclidean length of W -C subject to G*W+H*Z .GE. Y. -C This is the least projected distance problem, LPDP. -C The matrices G and H are of respective -C dimensions M by N1 and M by N2. -C -C Called by subprogram DLSI( ). -C -C The matrix -C (G H Y) -C -C occupies rows 1,...,M and cols 1,...,N1+N2+1 of A(*,*). -C -C The solution (W) is returned in X(*). -C (Z) -C -C The value of MODE indicates the status of -C the computation after returning to the user. -C -C MODE=1 The solution was successfully obtained. -C -C MODE=2 The inequalities are inconsistent. -C -C***SEE ALSO DLSEI -C***ROUTINES CALLED DCOPY, DDOT, DNRM2, DSCAL, DWNNLS -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE DLPDP - -C - INTEGER I, IS(*), IW, IX, J, L, M, MDA, MODE, MODEW, N, N1, N2, - * NP1 - DOUBLE PRECISION A(MDA,*), DDOT, DNRM2, FAC, ONE, - * PRGOPT(*), RNORM, SC, WNORM, WS(*), X(*), YNORM, ZERO - SAVE ZERO, ONE, FAC - DATA ZERO,ONE /0.0D0,1.0D0/, FAC /0.1D0/ -C***FIRST EXECUTABLE STATEMENT DLPDP - N = N1 + N2 - MODE = 1 - IF (M .GT. 0) GO TO 20 - IF (N .LE. 0) GO TO 10 - X(1) = ZERO - CALL DCOPY(N,X,0,X,1) - 10 CONTINUE - WNORM = ZERO - GO TO 200 - 20 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 190 - NP1 = N + 1 -C -C SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE. - DO 40 I = 1, M - SC = DNRM2(N,A(I,1),MDA) - IF (SC .EQ. ZERO) GO TO 30 - SC = ONE/SC - CALL DSCAL(NP1,SC,A(I,1),MDA) - 30 CONTINUE - 40 CONTINUE -C -C SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO). - YNORM = DNRM2(M,A(1,NP1),1) - IF (YNORM .EQ. ZERO) GO TO 50 - SC = ONE/YNORM - CALL DSCAL(M,SC,A(1,NP1),1) - 50 CONTINUE -C -C SCALE COLS OF MATRIX H. - J = N1 + 1 - 60 IF (J .GT. N) GO TO 70 - SC = DNRM2(M,A(1,J),1) - IF (SC .NE. ZERO) SC = ONE/SC - CALL DSCAL(M,SC,A(1,J),1) - X(J) = SC - J = J + 1 - GO TO 60 - 70 CONTINUE - IF (N1 .LE. 0) GO TO 130 -C -C COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*). - IW = 0 - DO 80 I = 1, M -C -C MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY. - CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) - IW = IW + N2 -C -C MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY. - CALL DCOPY(N1,A(I,1),MDA,WS(IW+1),1) - IW = IW + N1 -C -C MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY. - WS(IW+1) = A(I,NP1) - IW = IW + 1 - 80 CONTINUE - WS(IW+1) = ZERO - CALL DCOPY(N,WS(IW+1),0,WS(IW+1),1) - IW = IW + N - WS(IW+1) = ONE - IW = IW + 1 -C -C SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0. THE -C MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR -C F = TRANSPOSE OF (0,...,0,1). - IX = IW + 1 - IW = IW + M -C -C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF -C DWNNLS( ). - IS(1) = 0 - IS(2) = 0 - CALL DWNNLS(WS,NP1,N2,NP1-N2,M,0,PRGOPT,WS(IX),RNORM, - * MODEW,IS,WS(IW+1)) -C -C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W. - SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) - IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) - * GO TO 110 - SC = ONE/SC - DO 90 J = 1, N1 - X(J) = SC*DDOT(M,A(1,J),1,WS(IX),1) - 90 CONTINUE -C -C COMPUTE THE VECTOR Q=Y-GW. OVERWRITE Y WITH THIS -C VECTOR. - DO 100 I = 1, M - A(I,NP1) = A(I,NP1) - DDOT(N1,A(I,1),MDA,X,1) - 100 CONTINUE - GO TO 120 - 110 CONTINUE - MODE = 2 -C .........EXIT - GO TO 190 - 120 CONTINUE - 130 CONTINUE - IF (N2 .LE. 0) GO TO 180 -C -C COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*). - IW = 0 - DO 140 I = 1, M - CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) - IW = IW + N2 - WS(IW+1) = A(I,NP1) - IW = IW + 1 - 140 CONTINUE - WS(IW+1) = ZERO - CALL DCOPY(N2,WS(IW+1),0,WS(IW+1),1) - IW = IW + N2 - WS(IW+1) = ONE - IW = IW + 1 - IX = IW + 1 - IW = IW + M -C -C SOLVE RV=S SUBJECT TO V.GE.0. THE MATRIX R =(TRANSPOSE -C OF (H Q)), WHERE Q=Y-GW. THE (N2+1)-VECTOR S =(TRANSPOSE -C OF (0,...,0,1)). -C -C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF -C DWNNLS( ). - IS(1) = 0 - IS(2) = 0 - CALL DWNNLS(WS,N2+1,0,N2+1,M,0,PRGOPT,WS(IX),RNORM,MODEW, - * IS,WS(IW+1)) -C -C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z. - SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) - IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) - * GO TO 160 - SC = ONE/SC - DO 150 J = 1, N2 - L = N1 + J - X(L) = SC*DDOT(M,A(1,L),1,WS(IX),1)*X(L) - 150 CONTINUE - GO TO 170 - 160 CONTINUE - MODE = 2 -C .........EXIT - GO TO 190 - 170 CONTINUE - 180 CONTINUE -C -C ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION. - CALL DSCAL(N,YNORM,X,1) - WNORM = DNRM2(N1,X,1) - 190 CONTINUE - 200 CONTINUE - RETURN - END -*DECK DWNNLS - SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, - + IWORK, WORK) -C***BEGIN PROLOGUE DWNNLS -C***PURPOSE Solve a linearly constrained least squares problem with -C equality constraints and nonnegativity constraints on -C selected variables. -C***LIBRARY SLATEC -C***CATEGORY K1A2A -C***TYPE DOUBLE PRECISION (WNNLS-S, DWNNLS-D) -C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, -C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, -C NONNEGATIVITY CONSTRAINTS, QUADRATIC PROGRAMMING -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Abstract -C -C This subprogram solves a linearly constrained least squares -C problem. Suppose there are given matrices E and A of -C respective dimensions ME by N and MA by N, and vectors F -C and B of respective lengths ME and MA. This subroutine -C solves the problem -C -C EX = F, (equations to be exactly satisfied) -C -C AX = B, (equations to be approximately satisfied, -C in the least squares sense) -C -C subject to components L+1,...,N nonnegative -C -C Any values ME.GE.0, MA.GE.0 and 0.LE. L .LE.N are permitted. -C -C The problem is reposed as problem DWNNLS -C -C (WT*E)X = (WT*F) -C ( A) ( B), (least squares) -C subject to components L+1,...,N nonnegative. -C -C The subprogram chooses the heavy weight (or penalty parameter) WT. -C -C The parameters for DWNNLS are -C -C INPUT.. All TYPE REAL variables are DOUBLE PRECISION -C -C W(*,*),MDW, The array W(*,*) is double subscripted with first -C ME,MA,N,L dimensioning parameter equal to MDW. For this -C discussion let us call M = ME + MA. Then MDW -C must satisfy MDW.GE.M. The condition MDW.LT.M -C is an error. -C -C The array W(*,*) contains the matrices and vectors -C -C (E F) -C (A B) -C -C in rows and columns 1,...,M and 1,...,N+1 -C respectively. Columns 1,...,L correspond to -C unconstrained variables X(1),...,X(L). The -C remaining variables are constrained to be -C nonnegative. The condition L.LT.0 or L.GT.N is -C an error. -C -C PRGOPT(*) This double precision array is the option vector. -C If the user is satisfied with the nominal -C subprogram features set -C -C PRGOPT(1)=1 (or PRGOPT(1)=1.0) -C -C Otherwise PRGOPT(*) is a linked list consisting of -C groups of data of the following form -C -C LINK -C KEY -C DATA SET -C -C The parameters LINK and KEY are each one word. -C The DATA SET can be comprised of several words. -C The number of items depends on the value of KEY. -C The value of LINK points to the first -C entry of the next group of data within -C PRGOPT(*). The exception is when there are -C no more options to change. In that -C case LINK=1 and the values KEY and DATA SET -C are not referenced. The general layout of -C PRGOPT(*) is as follows. -C -C ...PRGOPT(1)=LINK1 (link to first entry of next group) -C . PRGOPT(2)=KEY1 (key to the option change) -C . PRGOPT(3)=DATA VALUE (data value for this change) -C . . -C . . -C . . -C ...PRGOPT(LINK1)=LINK2 (link to the first entry of -C . next group) -C . PRGOPT(LINK1+1)=KEY2 (key to the option change) -C . PRGOPT(LINK1+2)=DATA VALUE -C ... . -C . . -C . . -C ...PRGOPT(LINK)=1 (no more options to change) -C -C Values of LINK that are nonpositive are errors. -C A value of LINK.GT.NLINK=100000 is also an error. -C This helps prevent using invalid but positive -C values of LINK that will probably extend -C beyond the program limits of PRGOPT(*). -C Unrecognized values of KEY are ignored. The -C order of the options is arbitrary and any number -C of options can be changed with the following -C restriction. To prevent cycling in the -C processing of the option array a count of the -C number of options changed is maintained. -C Whenever this count exceeds NOPT=1000 an error -C message is printed and the subprogram returns. -C -C OPTIONS.. -C -C KEY=6 -C Scale the nonzero columns of the -C entire data matrix -C (E) -C (A) -C to have length one. The DATA SET for -C this option is a single value. It must -C be nonzero if unit length column scaling is -C desired. -C -C KEY=7 -C Scale columns of the entire data matrix -C (E) -C (A) -C with a user-provided diagonal matrix. -C The DATA SET for this option consists -C of the N diagonal scaling factors, one for -C each matrix column. -C -C KEY=8 -C Change the rank determination tolerance from -C the nominal value of SQRT(SRELPR). This quantity -C can be no smaller than SRELPR, The arithmetic- -C storage precision. The quantity used -C here is internally restricted to be at -C least SRELPR. The DATA SET for this option -C is the new tolerance. -C -C KEY=9 -C Change the blow-up parameter from the -C nominal value of SQRT(SRELPR). The reciprocal of -C this parameter is used in rejecting solution -C components as too large when a variable is -C first brought into the active set. Too large -C means that the proposed component times the -C reciprocal of the parameter is not less than -C the ratio of the norms of the right-side -C vector and the data matrix. -C This parameter can be no smaller than SRELPR, -C the arithmetic-storage precision. -C -C For example, suppose we want to provide -C a diagonal matrix to scale the problem -C matrix and change the tolerance used for -C determining linear dependence of dropped col -C vectors. For these options the dimensions of -C PRGOPT(*) must be at least N+6. The FORTRAN -C statements defining these options would -C be as follows. -C -C PRGOPT(1)=N+3 (link to entry N+3 in PRGOPT(*)) -C PRGOPT(2)=7 (user-provided scaling key) -C -C CALL DCOPY(N,D,1,PRGOPT(3),1) (copy the N -C scaling factors from a user array called D(*) -C into PRGOPT(3)-PRGOPT(N+2)) -C -C PRGOPT(N+3)=N+6 (link to entry N+6 of PRGOPT(*)) -C PRGOPT(N+4)=8 (linear dependence tolerance key) -C PRGOPT(N+5)=... (new value of the tolerance) -C -C PRGOPT(N+6)=1 (no more options to change) -C -C -C IWORK(1), The amounts of working storage actually allocated -C IWORK(2) for the working arrays WORK(*) and IWORK(*), -C respectively. These quantities are compared with -C the actual amounts of storage needed for DWNNLS( ). -C Insufficient storage allocated for either WORK(*) -C or IWORK(*) is considered an error. This feature -C was included in DWNNLS( ) because miscalculating -C the storage formulas for WORK(*) and IWORK(*) -C might very well lead to subtle and hard-to-find -C execution errors. -C -C The length of WORK(*) must be at least -C -C LW = ME+MA+5*N -C This test will not be made if IWORK(1).LE.0. -C -C The length of IWORK(*) must be at least -C -C LIW = ME+MA+N -C This test will not be made if IWORK(2).LE.0. -C -C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION -C -C X(*) An array dimensioned at least N, which will -C contain the N components of the solution vector -C on output. -C -C RNORM The residual norm of the solution. The value of -C RNORM contains the residual vector length of the -C equality constraints and least squares equations. -C -C MODE The value of MODE indicates the success or failure -C of the subprogram. -C -C MODE = 0 Subprogram completed successfully. -C -C = 1 Max. number of iterations (equal to -C 3*(N-L)) exceeded. Nearly all problems -C should complete in fewer than this -C number of iterations. An approximate -C solution and its corresponding residual -C vector length are in X(*) and RNORM. -C -C = 2 Usage error occurred. The offending -C condition is noted with the error -C processing subprogram, XERMSG( ). -C -C User-designated -C Working arrays.. -C -C WORK(*) A double precision working array of length at least -C M + 5*N. -C -C IWORK(*) An integer-valued working array of length at least -C M+N. -C -C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Report SAND77-0552, Sandia -C Laboratories, June 1978. -C K. H. Haskell and R. J. Hanson, Selected algorithms for -C the linearly constrained least squares problem - a -C users guide, Report SAND78-1290, Sandia Laboratories, -C August 1979. -C K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Mathematical Programming -C 21 (1981), pp. 98-118. -C R. J. Hanson and K. H. Haskell, Two algorithms for the -C linearly constrained least squares problem, ACM -C Transactions on Mathematical Software, September 1982. -C C. L. Lawson and R. J. Hanson, Solving Least Squares -C Problems, Prentice-Hall, Inc., 1974. -C***ROUTINES CALLED DWNLSM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls, change Prologue -C comments to agree with WNNLS. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Removed prints and replaced DP --> DOUBLE PRECISION. (THC) -C***END PROLOGUE DWNNLS - - INTEGER IWORK(*), L, L1, L2, L3, L4, L5, LIW, LW, MA, MDW, ME, - * MODE, N - DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) -C CHARACTER*8 XERN1 -C***FIRST EXECUTABLE STATEMENT DWNNLS - MODE = 0 - IF (MA+ME.LE.0 .OR. N.LE.0) RETURN -C - IF (IWORK(1).GT.0) THEN - LW = ME + MA + 5*N - IF (IWORK(1).LT.LW) THEN -C WRITE (XERN1, '(I8)') LW -C CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // -C * 'ALLOCATED FOR WORK(*), NEED LW = ' // XERN1, 2, 1) - MODE = 2 - RETURN - ENDIF - ENDIF -C - IF (IWORK(2).GT.0) THEN - LIW = ME + MA + N - IF (IWORK(2).LT.LIW) THEN -C WRITE (XERN1, '(I8)') LIW -C CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // -C * 'ALLOCATED FOR IWORK(*), NEED LIW = ' // XERN1, 2, 1) - MODE = 2 - RETURN - ENDIF - ENDIF -C - IF (MDW.LT.ME+MA) THEN -C CALL XERMSG ('SLATEC', 'DWNNLS', -C * 'THE VALUE MDW.LT.ME+MA IS AN ERROR', 1, 1) - MODE = 2 - RETURN - ENDIF -C - IF (L.LT.0 .OR. L.GT.N) THEN -C CALL XERMSG ('SLATEC', 'DWNNLS', -C * 'L.GE.0 .AND. L.LE.N IS REQUIRED', 2, 1) - MODE = 2 - RETURN - ENDIF -C -C THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS -C WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS -C REQUIRED BY THE MAIN SUBROUTINE DWNLSM( ). -C - L1 = N + 1 - L2 = L1 + N - L3 = L2 + ME + MA - L4 = L3 + N - L5 = L4 + N -C - CALL DWNLSM(W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, IWORK, - * IWORK(L1), WORK(1), WORK(L1), WORK(L2), WORK(L3), - * WORK(L4), WORK(L5)) - RETURN - END -*DECK DWNLSM - SUBROUTINE DWNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, - + IPIVOT, ITYPE, WD, H, SCALE, Z, TEMP, D) -C***BEGIN PROLOGUE DWNLSM -C***SUBSIDIARY -C***PURPOSE Subsidiary to DWNNLS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLSM-S, DWNLSM-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to DWNNLS. -C The documentation for DWNNLS has complete usage instructions. -C -C In addition to the parameters discussed in the prologue to -C subroutine DWNNLS, the following work arrays are used in -C subroutine DWNLSM (they are passed through the calling -C sequence from DWNNLS for purposes of variable dimensioning). -C Their contents will in general be of no interest to the user. -C -C Variables of type REAL are DOUBLE PRECISION. -C -C IPIVOT(*) -C An array of length N. Upon completion it contains the -C pivoting information for the cols of W(*,*). -C -C ITYPE(*) -C An array of length M which is used to keep track -C of the classification of the equations. ITYPE(I)=0 -C denotes equation I as an equality constraint. -C ITYPE(I)=1 denotes equation I as a least squares -C equation. -C -C WD(*) -C An array of length N. Upon completion it contains the -C dual solution vector. -C -C H(*) -C An array of length N. Upon completion it contains the -C pivot scalars of the Householder transformations performed -C in the case KRANK.LT.L. -C -C SCALE(*) -C An array of length M which is used by the subroutine -C to store the diagonal matrix of weights. -C These are used to apply the modified Givens -C transformations. -C -C Z(*),TEMP(*) -C Working arrays of length N. -C -C D(*) -C An array of length N that contains the -C column scaling for the matrix (E). -C (A) -C -C***SEE ALSO DWNNLS -C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, -C SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, -C DWNLIT, IDAMAX, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Fixed an error message. (RWC) -C 900604 DP version created from SP version. (RWC) -C 900911 Restriction on value of ALAMDA included. (WRB) -C***END PROLOGUE DWNLSM - - INTEGER IPIVOT(*), ITYPE(*), L, MA, MDW, MME, MODE, N - DOUBLE PRECISION D(*), H(*), PRGOPT(*), RNORM, SCALE(*), TEMP(*), - * W(MDW,*), WD(*), X(*), Z(*) -C - EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, SLATEC_DROTM, - * SLATEC_DROTMG, DSCAL, DSWAP, DWNLIT, IDAMAX, XERMSG - DOUBLE PRECISION D1MACH, DASUM, DNRM2 - INTEGER IDAMAX -C - DOUBLE PRECISION ALAMDA, ALPHA, ALSQ, AMAX, BLOWUP, BNORM, - * DOPE(3), DRELPR, EANORM, FAC, SM, SPARAM(5), T, TAU, WMAX, Z2, - * ZZ - INTEGER I, IDOPE(3), IMAX, ISOL, ITEMP, ITER, ITMAX, IWMAX, J, - * JCON, JP, KEY, KRANK, L1, LAST, LINK, M, ME, NEXT, NIV, NLINK, - * NOPT, NSOLN, NTIMES - LOGICAL DONE, FEASBL, FIRST, HITCON, POS -C - SAVE DRELPR, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DWNLSM -C -C Initialize variables. -C DRELPR is the precision for the particular machine -C being used. This logic avoids resetting it every entry. -C - IF (FIRST) DRELPR = D1MACH(4) - FIRST = .FALSE. -C -C Set the nominal tolerance used in the code. -C - TAU = SQRT(DRELPR) -C - M = MA + MME - ME = MME - MODE = 2 -C -C To process option vector -C - FAC = 1.D-4 -C -C Set the nominal blow up factor used in the code. -C - BLOWUP = TAU -C -C The nominal column scaling used in the code is -C the identity scaling. -C - CALL DCOPY (N, 1.D0, 0, D, 1) -C -C Define bound for number of options to change. -C - NOPT = 1000 -C -C Define bound for positive value of LINK. -C - NLINK = 100000 - NTIMES = 0 - LAST = 1 - LINK = PRGOPT(1) - IF (LINK.LE.0 .OR. LINK.GT.NLINK) THEN -C CALL XERMSG ('SLATEC', 'DWNLSM', -C + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) - RETURN - ENDIF -C - 100 IF (LINK.GT.1) THEN - NTIMES = NTIMES + 1 - IF (NTIMES.GT.NOPT) THEN -C CALL XERMSG ('SLATEC', 'DWNLSM', -C + 'IN DWNNLS, THE LINKS IN THE OPTION VECTOR ARE CYCLING.', -C + 3, 1) - RETURN - ENDIF -C - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.6 .AND. PRGOPT(LAST+2).NE.0.D0) THEN - DO 110 J = 1,N - T = DNRM2(M,W(1,J),1) - IF (T.NE.0.D0) T = 1.D0/T - D(J) = T - 110 CONTINUE - ENDIF -C - IF (KEY.EQ.7) CALL DCOPY (N, PRGOPT(LAST+2), 1, D, 1) - IF (KEY.EQ.8) TAU = MAX(DRELPR,PRGOPT(LAST+2)) - IF (KEY.EQ.9) BLOWUP = MAX(DRELPR,PRGOPT(LAST+2)) -C - NEXT = PRGOPT(LINK) - IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN -C CALL XERMSG ('SLATEC', 'DWNLSM', -C + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) - RETURN - ENDIF -C - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C - DO 120 J = 1,N - CALL DSCAL (M, D(J), W(1,J), 1) - 120 CONTINUE -C -C Process option vector -C - DONE = .FALSE. - ITER = 0 - ITMAX = 3*(N-L) - MODE = 0 - NSOLN = L - L1 = MIN(M,L) -C -C Compute scale factor to apply to equality constraint equations. -C - DO 130 J = 1,N - WD(J) = DASUM(M,W(1,J),1) - 130 CONTINUE -C - IMAX = IDAMAX(N,WD,1) - EANORM = WD(IMAX) - BNORM = DASUM(M,W(1,N+1),1) - ALAMDA = EANORM/(DRELPR*FAC) -C -C On machines, such as the VAXes using D floating, with a very -C limited exponent range for double precision values, the previously -C computed value of ALAMDA may cause an overflow condition. -C Therefore, this code further limits the value of ALAMDA. -C - ALAMDA = MIN(ALAMDA,SQRT(D1MACH(2))) -C -C Define scaling diagonal matrix for modified Givens usage and -C classify equation types. -C - ALSQ = ALAMDA**2 - DO 140 I = 1,M -C -C When equation I is heavily weighted ITYPE(I)=0, -C else ITYPE(I)=1. -C - IF (I.LE.ME) THEN - T = ALSQ - ITEMP = 0 - ELSE - T = 1.D0 - ITEMP = 1 - ENDIF - SCALE(I) = T - ITYPE(I) = ITEMP - 140 CONTINUE -C -C Set the solution vector X(*) to zero and the column interchange -C matrix to the identity. -C - CALL DCOPY (N, 0.D0, 0, X, 1) - DO 150 I = 1,N - IPIVOT(I) = I - 150 CONTINUE -C -C Perform initial triangularization in the submatrix -C corresponding to the unconstrained variables. -C Set first L components of dual vector to zero because -C these correspond to the unconstrained variables. -C - CALL DCOPY (L, 0.D0, 0, WD, 1) -C -C The arrays IDOPE(*) and DOPE(*) are used to pass -C information to DWNLIT(). This was done to avoid -C a long calling sequence or the use of COMMON. -C - IDOPE(1) = ME - IDOPE(2) = NSOLN - IDOPE(3) = L1 -C - DOPE(1) = ALSQ - DOPE(2) = EANORM - DOPE(3) = TAU - CALL DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM, - + IDOPE, DOPE, DONE) - ME = IDOPE(1) - KRANK = IDOPE(2) - NIV = IDOPE(3) -C -C Perform WNNLS algorithm using the following steps. -C -C Until(DONE) -C compute search direction and feasible point -C when (HITCON) add constraints -C else perform multiplier test and drop a constraint -C fin -C Compute-Final-Solution -C -C To compute search direction and feasible point, -C solve the triangular system of currently non-active -C variables and store the solution in Z(*). -C -C To solve system -C Copy right hand side into TEMP vector to use overwriting method. -C - 160 IF (DONE) GO TO 330 - ISOL = L + 1 - IF (NSOLN.GE.ISOL) THEN - CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) - DO 170 J = NSOLN,ISOL,-1 - IF (J.GT.KRANK) THEN - I = NIV - NSOLN + J - ELSE - I = J - ENDIF -C - IF (J.GT.KRANK .AND. J.LE.L) THEN - Z(J) = 0.D0 - ELSE - Z(J) = TEMP(I)/W(I,J) - CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) - ENDIF - 170 CONTINUE - ENDIF -C -C Increment iteration counter and check against maximum number -C of iterations. -C - ITER = ITER + 1 - IF (ITER.GT.ITMAX) THEN - MODE = 1 - DONE = .TRUE. - ENDIF -C -C Check to see if any constraints have become active. -C If so, calculate an interpolation factor so that all -C active constraints are removed from the basis. -C - ALPHA = 2.D0 - HITCON = .FALSE. - DO 180 J = L+1,NSOLN - ZZ = Z(J) - IF (ZZ.LE.0.D0) THEN - T = X(J)/(X(J)-ZZ) - IF (T.LT.ALPHA) THEN - ALPHA = T - JCON = J - ENDIF - HITCON = .TRUE. - ENDIF - 180 CONTINUE -C -C Compute search direction and feasible point -C - IF (HITCON) THEN -C -C To add constraints, use computed ALPHA to interpolate between -C last feasible solution X(*) and current unconstrained (and -C infeasible) solution Z(*). -C - DO 190 J = L+1,NSOLN - X(J) = X(J) + ALPHA*(Z(J)-X(J)) - 190 CONTINUE - FEASBL = .FALSE. -C -C Remove column JCON and shift columns JCON+1 through N to the -C left. Swap column JCON into the N th position. This achieves -C upper Hessenberg form for the nonactive constraints and -C leaves an upper Hessenberg matrix to retriangularize. -C - 200 DO 210 I = 1,M - T = W(I,JCON) - CALL DCOPY (N-JCON, W(I, JCON+1), MDW, W(I, JCON), MDW) - W(I,N) = T - 210 CONTINUE -C -C Update permuted index vector to reflect this shift and swap. -C - ITEMP = IPIVOT(JCON) - DO 220 I = JCON,N - 1 - IPIVOT(I) = IPIVOT(I+1) - 220 CONTINUE - IPIVOT(N) = ITEMP -C -C Similarly permute X(*) vector. -C - CALL DCOPY (N-JCON, X(JCON+1), 1, X(JCON), 1) - X(N) = 0.D0 - NSOLN = NSOLN - 1 - NIV = NIV - 1 -C -C Retriangularize upper Hessenberg matrix after adding -C constraints. -C - I = KRANK + JCON - L - DO 230 J = JCON,NSOLN - IF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.0) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), - + MDW, SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.1) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), - + MDW, SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.0) THEN - CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) - CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) - ITEMP = ITYPE(I+1) - ITYPE(I+1) = ITYPE(I) - ITYPE(I) = ITEMP -C -C Swapped row was formerly a pivot element, so it will -C be large enough to perform elimination. -C Zero IP1 to I in column J. -C - IF (W(I+1,J).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), - + MDW, SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.1) THEN - IF (SCALE(I)*W(I,J)**2/ALSQ.GT.(TAU*EANORM)**2) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, - + W(I+1,J+1), MDW, SPARAM) - ENDIF - ELSE - CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) - CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) - ITEMP = ITYPE(I+1) - ITYPE(I+1) = ITYPE(I) - ITYPE(I) = ITEMP - W(I+1,J) = 0.D0 - ENDIF - ENDIF - I = I + 1 - 230 CONTINUE -C -C See if the remaining coefficients in the solution set are -C feasible. They should be because of the way ALPHA was -C determined. If any are infeasible, it is due to roundoff -C error. Any that are non-positive will be set to zero and -C removed from the solution set. -C - DO 240 JCON = L+1,NSOLN - IF (X(JCON).LE.0.D0) GO TO 250 - 240 CONTINUE - FEASBL = .TRUE. - 250 IF (.NOT.FEASBL) GO TO 200 - ELSE -C -C To perform multiplier test and drop a constraint. -C - CALL DCOPY (NSOLN, Z, 1, X, 1) - IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) -C -C Reclassify least squares equations as equalities as necessary. -C - I = NIV + 1 - 260 IF (I.LE.ME) THEN - IF (ITYPE(I).EQ.0) THEN - I = I + 1 - ELSE - CALL DSWAP (N+1, W(I,1), MDW, W(ME,1), MDW) - CALL DSWAP (1, SCALE(I), 1, SCALE(ME), 1) - ITEMP = ITYPE(I) - ITYPE(I) = ITYPE(ME) - ITYPE(ME) = ITEMP - ME = ME - 1 - ENDIF - GO TO 260 - ENDIF -C -C Form inner product vector WD(*) of dual coefficients. -C - DO 280 J = NSOLN+1,N - SM = 0.D0 - DO 270 I = NSOLN+1,M - SM = SM + SCALE(I)*W(I,J)*W(I,N+1) - 270 CONTINUE - WD(J) = SM - 280 CONTINUE -C -C Find J such that WD(J)=WMAX is maximum. This determines -C that the incoming column J will reduce the residual vector -C and be positive. -C - 290 WMAX = 0.D0 - IWMAX = NSOLN + 1 - DO 300 J = NSOLN+1,N - IF (WD(J).GT.WMAX) THEN - WMAX = WD(J) - IWMAX = J - ENDIF - 300 CONTINUE - IF (WMAX.LE.0.D0) GO TO 330 -C -C Set dual coefficients to zero for incoming column. -C - WD(IWMAX) = 0.D0 -C -C WMAX .GT. 0.D0, so okay to move column IWMAX to solution set. -C Perform transformation to retriangularize, and test for near -C linear dependence. -C -C Swap column IWMAX into NSOLN-th position to maintain upper -C Hessenberg form of adjacent columns, and add new column to -C triangular decomposition. -C - NSOLN = NSOLN + 1 - NIV = NIV + 1 - IF (NSOLN.NE.IWMAX) THEN - CALL DSWAP (M, W(1,NSOLN), 1, W(1,IWMAX), 1) - WD(IWMAX) = WD(NSOLN) - WD(NSOLN) = 0.D0 - ITEMP = IPIVOT(NSOLN) - IPIVOT(NSOLN) = IPIVOT(IWMAX) - IPIVOT(IWMAX) = ITEMP - ENDIF -C -C Reduce column NSOLN so that the matrix of nonactive constraints -C variables is triangular. -C - DO 320 J = M,NIV+1,-1 - JP = J - 1 -C -C When operating near the ME line, test to see if the pivot -C element is near zero. If so, use the largest element above -C it as the pivot. This is to maintain the sharp interface -C between weighted and non-weighted rows in all cases. -C - IF (J.EQ.ME+1) THEN - IMAX = ME - AMAX = SCALE(ME)*W(ME,NSOLN)**2 - DO 310 JP = J - 1,NIV,-1 - T = SCALE(JP)*W(JP,NSOLN)**2 - IF (T.GT.AMAX) THEN - IMAX = JP - AMAX = T - ENDIF - 310 CONTINUE - JP = IMAX - ENDIF -C - IF (W(J,NSOLN).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(JP), SCALE(J), W(JP,NSOLN), - + W(J,NSOLN), SPARAM) - W(J,NSOLN) = 0.D0 - CALL SLATEC_DROTM (N+1-NSOLN, W(JP,NSOLN+1), MDW, - + W(J,NSOLN+1), MDW, SPARAM) - ENDIF - 320 CONTINUE -C -C Solve for Z(NSOLN)=proposed new value for X(NSOLN). Test if -C this is nonpositive or too large. If this was true or if the -C pivot term was zero, reject the column as dependent. -C - IF (W(NIV,NSOLN).NE.0.D0) THEN - ISOL = NIV - Z2 = W(ISOL,N+1)/W(ISOL,NSOLN) - Z(NSOLN) = Z2 - POS = Z2 .GT. 0.D0 - IF (Z2*EANORM.GE.BNORM .AND. POS) THEN - POS = .NOT. (BLOWUP*Z2*EANORM.GE.BNORM) - ENDIF -C -C Try to add row ME+1 as an additional equality constraint. -C Check size of proposed new solution component. -C Reject it if it is too large. -C - ELSEIF (NIV.LE.ME .AND. W(ME+1,NSOLN).NE.0.D0) THEN - ISOL = ME + 1 - IF (POS) THEN -C -C Swap rows ME+1 and NIV, and scale factors for these rows. -C - CALL DSWAP (N+1, W(ME+1,1), MDW, W(NIV,1), MDW) - CALL DSWAP (1, SCALE(ME+1), 1, SCALE(NIV), 1) - ITEMP = ITYPE(ME+1) - ITYPE(ME+1) = ITYPE(NIV) - ITYPE(NIV) = ITEMP - ME = ME + 1 - ENDIF - ELSE - POS = .FALSE. - ENDIF -C - IF (.NOT.POS) THEN - NSOLN = NSOLN - 1 - NIV = NIV - 1 - ENDIF - IF (.NOT.(POS.OR.DONE)) GO TO 290 - ENDIF - GO TO 160 -C -C Else perform multiplier test and drop a constraint. To compute -C final solution. Solve system, store results in X(*). -C -C Copy right hand side into TEMP vector to use overwriting method. -C - 330 ISOL = 1 - IF (NSOLN.GE.ISOL) THEN - CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) - DO 340 J = NSOLN,ISOL,-1 - IF (J.GT.KRANK) THEN - I = NIV - NSOLN + J - ELSE - I = J - ENDIF -C - IF (J.GT.KRANK .AND. J.LE.L) THEN - Z(J) = 0.D0 - ELSE - Z(J) = TEMP(I)/W(I,J) - CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) - ENDIF - 340 CONTINUE - ENDIF -C -C Solve system. -C - CALL DCOPY (NSOLN, Z, 1, X, 1) -C -C Apply Householder transformations to X(*) if KRANK.LT.L -C - IF (KRANK.LT.L) THEN - DO 350 I = 1,KRANK - CALL DH12 (2, I, KRANK+1, L, W(I,1), MDW, H(I), X, 1, 1, 1) - 350 CONTINUE - ENDIF -C -C Fill in trailing zeroes for constrained variables not in solution. -C - IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) -C -C Permute solution vector to natural order. -C - DO 380 I = 1,N - J = I - 360 IF (IPIVOT(J).EQ.I) GO TO 370 - J = J + 1 - GO TO 360 -C - 370 IPIVOT(J) = IPIVOT(I) - IPIVOT(I) = J - CALL DSWAP (1, X(J), 1, X(I), 1) - 380 CONTINUE -C -C Rescale the solution using the column scaling. -C - DO 390 J = 1,N - X(J) = X(J)*D(J) - 390 CONTINUE -C - DO 400 I = NSOLN+1,M - T = W(I,N+1) - IF (I.LE.ME) T = T/ALAMDA - T = (SCALE(I)*T)*T - RNORM = RNORM + T - 400 CONTINUE -C - RNORM = SQRT(RNORM) - RETURN - END -*DECK DROTM - SUBROUTINE SLATEC_DROTM (N, DX, INCX, DY, INCY, DPARAM) -C***BEGIN PROLOGUE SLATEC_DROTM -C***PURPOSE Apply a modified Givens transformation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A8 -C***TYPE DOUBLE PRECISION (SROTM-S, DROTM-D) -C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C Kincaid, D. R., (U. of Texas) -C Krogh, F. T., (JPL) -C***DESCRIPTION -C -C B L A S Subprogram -C Description of Parameters -C -C --Input-- -C N number of elements in input vector(s) -C DX double precision vector with N elements -C INCX storage spacing between elements of DX -C DY double precision vector with N elements -C INCY storage spacing between elements of DY -C DPARAM 5-element D.P. vector. DPARAM(1) is DFLAG described below. -C Locations 2-5 of SPARAM contain elements of the -C transformation matrix H described below. -C -C --Output-- -C DX rotated vector (unchanged if N .LE. 0) -C DY rotated vector (unchanged if N .LE. 0) -C -C Apply the modified Givens transformation, H, to the 2 by N matrix -C (DX**T) -C (DY**T) , where **T indicates transpose. The elements of DX are -C in DX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else -C LX = 1+(1-N)*INCX, and similarly for DY using LY and INCY. -C -C With DPARAM(1)=DFLAG, H has one of the following forms: -C -C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 -C -C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) -C H=( ) ( ) ( ) ( ) -C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). -C -C See SLATEC_DROTMG for a description of data storage in DPARAM. -C -C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. -C Krogh, Basic linear algebra subprograms for Fortran -C usage, Algorithm No. 539, Transactions on Mathematical -C Software 5, 3 (September 1979), pp. 308-323. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920310 Corrected definition of LX in DESCRIPTION. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Renamed SLATEC_DROTM to avoid BLAS naming conflict. (THC) -C***END PROLOGUE SLATEC_DROTM - - DOUBLE PRECISION DFLAG, DH12, DH22, DX, TWO, Z, DH11, DH21, - 1 DPARAM, DY, W, ZERO - DIMENSION DX(*), DY(*), DPARAM(5) - SAVE ZERO, TWO - DATA ZERO, TWO /0.0D0, 2.0D0/ -C***FIRST EXECUTABLE STATEMENT SLATEC_DROTM - DFLAG=DPARAM(1) - IF (N.LE.0 .OR. (DFLAG+TWO.EQ.ZERO)) GO TO 140 - IF (.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 -C - NSTEPS=N*INCX -C IF (DFLAG) 50, 10, 30 -C Replaced obsolete code above with an IF-block (THC). - IF (DFLAG < 0) THEN - GO TO 50 - ELSE IF (DFLAG == 0) THEN - GO TO 10 - ELSE IF (DFLAG > 0) THEN - GO TO 30 - END IF - 10 CONTINUE - DH12=DPARAM(4) - DH21=DPARAM(3) - DO 20 I = 1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W+Z*DH12 - DY(I)=W*DH21+Z - 20 CONTINUE - GO TO 140 - 30 CONTINUE - DH11=DPARAM(2) - DH22=DPARAM(5) - DO 40 I = 1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W*DH11+Z - DY(I)=-W+DH22*Z - 40 CONTINUE - GO TO 140 - 50 CONTINUE - DH11=DPARAM(2) - DH12=DPARAM(4) - DH21=DPARAM(3) - DH22=DPARAM(5) - DO 60 I = 1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W*DH11+Z*DH12 - DY(I)=W*DH21+Z*DH22 - 60 CONTINUE - GO TO 140 - 70 CONTINUE - KX=1 - KY=1 - IF (INCX .LT. 0) KX = 1+(1-N)*INCX - IF (INCY .LT. 0) KY = 1+(1-N)*INCY -C -C IF (DFLAG) 120,80,100 -C Replaced obsolete code above with an IF-block (THC). - IF (DFLAG < 0) THEN - GO TO 120 - ELSE IF (DFLAG == 0) THEN - GO TO 80 - ELSE IF (DFLAG > 0) THEN - GO TO 100 - END IF - 80 CONTINUE - DH12=DPARAM(4) - DH21=DPARAM(3) - DO 90 I = 1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W+Z*DH12 - DY(KY)=W*DH21+Z - KX=KX+INCX - KY=KY+INCY - 90 CONTINUE - GO TO 140 - 100 CONTINUE - DH11=DPARAM(2) - DH22=DPARAM(5) - DO 110 I = 1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W*DH11+Z - DY(KY)=-W+DH22*Z - KX=KX+INCX - KY=KY+INCY - 110 CONTINUE - GO TO 140 - 120 CONTINUE - DH11=DPARAM(2) - DH12=DPARAM(4) - DH21=DPARAM(3) - DH22=DPARAM(5) - DO 130 I = 1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W*DH11+Z*DH12 - DY(KY)=W*DH21+Z*DH22 - KX=KX+INCX - KY=KY+INCY - 130 CONTINUE - 140 CONTINUE - RETURN - END -*DECK SLATEC_DROTMG - SUBROUTINE SLATEC_DROTMG (DD1, DD2, DX1, DY1, DPARAM) -C***BEGIN PROLOGUE SLATEC_DROTMG -C***PURPOSE Construct a modified Givens transformation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B10 -C***TYPE DOUBLE PRECISION (SROTMG-S, DROTMG-D) -C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C Kincaid, D. R., (U. of Texas) -C Krogh, F. T., (JPL) -C***DESCRIPTION -C -C B L A S Subprogram -C Description of Parameters -C -C --Input-- -C DD1 double precision scalar -C DD2 double precision scalar -C DX1 double precision scalar -C DX2 double precision scalar -C DPARAM D.P. 5-vector. DPARAM(1)=DFLAG defined below. -C Locations 2-5 contain the rotation matrix. -C -C --Output-- -C DD1 changed to represent the effect of the transformation -C DD2 changed to represent the effect of the transformation -C DX1 changed to represent the effect of the transformation -C DX2 unchanged -C -C Construct the modified Givens transformation matrix H which zeros -C the second component of the 2-vector (SQRT(DD1)*DX1,SQRT(DD2)* -C DY2)**T. -C With DPARAM(1)=DFLAG, H has one of the following forms: -C -C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 -C -C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) -C H=( ) ( ) ( ) ( ) -C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). -C -C Locations 2-5 of DPARAM contain DH11, DH21, DH12, and DH22, -C respectively. (Values of 1.D0, -1.D0, or 0.D0 implied by the -C value of DPARAM(1) are not stored in DPARAM.) -C -C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. -C Krogh, Basic linear algebra subprograms for Fortran -C usage, Algorithm No. 539, Transactions on Mathematical -C Software 5, 3 (September 1979), pp. 308-323. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920316 Prologue corrected. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Renamed SLATEC_DROTMG to avoid BLAS naming conflict. (THC) -C***END PROLOGUE SLATEC_DROTMG - - DOUBLE PRECISION GAM, ONE, RGAMSQ, DD1, DD2, DH11, DH12, DH21, - 1 DH22, DPARAM, DP1, DP2, DQ1, DQ2, DU, DY1, ZERO, - 2 GAMSQ, DFLAG, DTEMP, DX1, TWO - DIMENSION DPARAM(5) - SAVE ZERO, ONE, TWO, GAM, GAMSQ, RGAMSQ - DATA ZERO, ONE, TWO /0.0D0, 1.0D0, 2.0D0/ - DATA GAM, GAMSQ, RGAMSQ /4096.0D0, 16777216.D0, 5.9604645D-8/ -C***FIRST EXECUTABLE STATEMENT SLATEC_DROTMG - IF (.NOT. DD1 .LT. ZERO) GO TO 10 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 10 CONTINUE -C CASE-DD1-NONNEGATIVE - DP2=DD2*DY1 - IF (.NOT. DP2 .EQ. ZERO) GO TO 20 - DFLAG=-TWO - GO TO 260 -C REGULAR-CASE.. - 20 CONTINUE - DP1=DD1*DX1 - DQ2=DP2*DY1 - DQ1=DP1*DX1 -C - IF (.NOT. ABS(DQ1) .GT. ABS(DQ2)) GO TO 40 - DH21=-DY1/DX1 - DH12=DP2/DP1 -C - DU=ONE-DH12*DH21 -C - IF (.NOT. DU .LE. ZERO) GO TO 30 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 30 CONTINUE - DFLAG=ZERO - DD1=DD1/DU - DD2=DD2/DU - DX1=DX1*DU -C GO SCALE-CHECK.. - GO TO 100 - 40 CONTINUE - IF (.NOT. DQ2 .LT. ZERO) GO TO 50 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 50 CONTINUE - DFLAG=ONE - DH11=DP1/DP2 - DH22=DX1/DY1 - DU=ONE+DH11*DH22 - DTEMP=DD2/DU - DD2=DD1/DU - DD1=DTEMP - DX1=DY1*DU -C GO SCALE-CHECK - GO TO 100 -C PROCEDURE..ZERO-H-D-AND-DX1.. - 60 CONTINUE - DFLAG=-ONE - DH11=ZERO - DH12=ZERO - DH21=ZERO - DH22=ZERO -C - DD1=ZERO - DD2=ZERO - DX1=ZERO -C RETURN.. - GO TO 220 -C PROCEDURE..FIX-H.. - 70 CONTINUE - IF (.NOT. DFLAG .GE. ZERO) GO TO 90 -C - IF (.NOT. DFLAG .EQ. ZERO) GO TO 80 - DH11=ONE - DH22=ONE - DFLAG=-ONE - GO TO 90 - 80 CONTINUE - DH21=-ONE - DH12=ONE - DFLAG=-ONE - 90 CONTINUE -C GO TO IGO,(120,150,180,210) -C Replaced the above obsolete code with modern alternative (THC). - SELECT CASE(IGO) - CASE(120) - GO TO 120 - CASE(150) - GO TO 150 - CASE(180) - GO TO 180 - CASE(210) - GO TO 210 - END SELECT -C PROCEDURE..SCALE-CHECK - 100 CONTINUE - 110 CONTINUE - IF (.NOT. DD1 .LE. RGAMSQ) GO TO 130 - IF (DD1 .EQ. ZERO) GO TO 160 - IGO = 120 -C FIX-H.. - GO TO 70 - 120 CONTINUE - DD1=DD1*GAM**2 - DX1=DX1/GAM - DH11=DH11/GAM - DH12=DH12/GAM - GO TO 110 - 130 CONTINUE - 140 CONTINUE - IF (.NOT. DD1 .GE. GAMSQ) GO TO 160 - IGO = 150 -C FIX-H.. - GO TO 70 - 150 CONTINUE - DD1=DD1/GAM**2 - DX1=DX1*GAM - DH11=DH11*GAM - DH12=DH12*GAM - GO TO 140 - 160 CONTINUE - 170 CONTINUE - IF (.NOT. ABS(DD2) .LE. RGAMSQ) GO TO 190 - IF (DD2 .EQ. ZERO) GO TO 220 - IGO = 180 -C FIX-H.. - GO TO 70 - 180 CONTINUE - DD2=DD2*GAM**2 - DH21=DH21/GAM - DH22=DH22/GAM - GO TO 170 - 190 CONTINUE - 200 CONTINUE - IF (.NOT. ABS(DD2) .GE. GAMSQ) GO TO 220 - IGO = 210 -C FIX-H.. - GO TO 70 - 210 CONTINUE - DD2=DD2/GAM**2 - DH21=DH21*GAM - DH22=DH22*GAM - GO TO 200 - 220 CONTINUE -C IF (DFLAG) 250,230,240 -C Replaced obsolete code above with an IF-block (THC). - IF (DFLAG < 0) THEN - GO TO 250 - ELSE IF (DFLAG == 0) THEN - GO TO 230 - ELSE IF (DFLAG > 0) THEN - GO TO 240 - END IF - - 230 CONTINUE - DPARAM(3)=DH21 - DPARAM(4)=DH12 - GO TO 260 - 240 CONTINUE - DPARAM(2)=DH11 - DPARAM(5)=DH22 - GO TO 260 - 250 CONTINUE - DPARAM(2)=DH11 - DPARAM(3)=DH21 - DPARAM(4)=DH12 - DPARAM(5)=DH22 - 260 CONTINUE - DPARAM(1)=DFLAG - RETURN - END -*DECK DWNLIT - SUBROUTINE DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, - + RNORM, IDOPE, DOPE, DONE) -C***BEGIN PROLOGUE DWNLIT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DWNNLS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLIT-S, DWNLIT-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to DWNNLS( ). -C The documentation for DWNNLS( ) has complete usage instructions. -C -C Note The M by (N+1) matrix W( , ) contains the rt. hand side -C B as the (N+1)st col. -C -C Triangularize L1 by L1 subsystem, where L1=MIN(M,L), with -C col interchanges. -C -C***SEE ALSO DWNNLS -C***ROUTINES CALLED DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, -C DSWAP, DWNLT1, DWNLT2, DWNLT3, IDAMAX -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -C 890620 Revised to make WNLT1, WNLT2, and WNLT3 subroutines. (RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900604 DP version created from SP version. . (RWC) -C***END PROLOGUE DWNLIT - - INTEGER IDOPE(*), IPIVOT(*), ITYPE(*), L, M, MDW, N - DOUBLE PRECISION DOPE(*), H(*), RNORM, SCALE(*), W(MDW,*) - LOGICAL DONE -C - EXTERNAL DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, - * DWNLT1, DWNLT2, DWNLT3, IDAMAX - INTEGER IDAMAX - LOGICAL DWNLT2 -C - DOUBLE PRECISION ALSQ, AMAX, EANORM, FACTOR, HBAR, RN, SPARAM(5), - * T, TAU - INTEGER I, I1, IMAX, IR, J, J1, JJ, JP, KRANK, L1, LB, LEND, ME, - * MEND, NIV, NSOLN - LOGICAL INDEP, RECALC -C -C***FIRST EXECUTABLE STATEMENT DWNLIT - ME = IDOPE(1) - NSOLN = IDOPE(2) - L1 = IDOPE(3) -C - ALSQ = DOPE(1) - EANORM = DOPE(2) - TAU = DOPE(3) -C - LB = MIN(M-1,L) - RECALC = .TRUE. - RNORM = 0.D0 - KRANK = 0 -C -C We set FACTOR=1.0 so that the heavy weight ALAMDA will be -C included in the test for column independence. -C - FACTOR = 1.D0 - LEND = L - DO 180 I=1,LB -C -C Set IR to point to the I-th row. -C - IR = I - MEND = M - CALL DWNLT1 (I, LEND, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, - + W) -C -C Update column SS and find pivot column. -C - CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange. -C Test independence of incoming column. -C - 130 IF (DWNLT2(ME, MEND, IR, FACTOR, TAU, SCALE, W(1,I))) THEN -C -C Eliminate I-th column below diagonal using modified Givens -C transformations applied to (A B). -C -C When operating near the ME line, use the largest element -C above it as the pivot. -C - DO 160 J=M,I+1,-1 - JP = J-1 - IF (J.EQ.ME+1) THEN - IMAX = ME - AMAX = SCALE(ME)*W(ME,I)**2 - DO 150 JP=J-1,I,-1 - T = SCALE(JP)*W(JP,I)**2 - IF (T.GT.AMAX) THEN - IMAX = JP - AMAX = T - ENDIF - 150 CONTINUE - JP = IMAX - ENDIF -C - IF (W(J,I).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(JP), SCALE(J), W(JP,I), - + W(J,I), SPARAM) - W(J,I) = 0.D0 - CALL SLATEC_DROTM (N+1-I, W(JP,I+1), MDW, W(J,I+1), - + MDW, SPARAM) - ENDIF - 160 CONTINUE - ELSE IF (LEND.GT.I) THEN -C -C Column I is dependent. Swap with column LEND. -C Perform column interchange, -C and find column in remaining set with largest SS. -C - CALL DWNLT3 (I, LEND, M, MDW, IPIVOT, H, W) - LEND = LEND - 1 - IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 - HBAR = H(IMAX) - GO TO 130 - ELSE - KRANK = I - 1 - GO TO 190 - ENDIF - 180 CONTINUE - KRANK = L1 -C - 190 IF (KRANK.LT.ME) THEN - FACTOR = ALSQ - DO 200 I=KRANK+1,ME - CALL DCOPY (L, 0.D0, 0, W(I,1), MDW) - 200 CONTINUE -C -C Determine the rank of the remaining equality constraint -C equations by eliminating within the block of constrained -C variables. Remove any redundant constraints. -C - RECALC = .TRUE. - LB = MIN(L+ME-KRANK, N) - DO 270 I=L+1,LB - IR = KRANK + I - L - LEND = N - MEND = ME - CALL DWNLT1 (I, LEND, ME, IR, MDW, RECALC, IMAX, HBAR, H, - + SCALE, W) -C -C Update col ss and find pivot col -C - CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange -C Eliminate elements in the I-th col. -C - DO 240 J=ME,IR+1,-1 - IF (W(J,I).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), - + W(J,I), SPARAM) - W(J,I) = 0.D0 - CALL SLATEC_DROTM (N+1-I, W(J-1,I+1), MDW,W(J,I+1), - + MDW, SPARAM) - ENDIF - 240 CONTINUE -C -C I=column being eliminated. -C Test independence of incoming column. -C Remove any redundant or dependent equality constraints. -C - IF (.NOT.DWNLT2(ME, MEND, IR, FACTOR,TAU,SCALE,W(1,I))) THEN - JJ = IR - DO 260 IR=JJ,ME - CALL DCOPY (N, 0.D0, 0, W(IR,1), MDW) - RNORM = RNORM + (SCALE(IR)*W(IR,N+1)/ALSQ)*W(IR,N+1) - W(IR,N+1) = 0.D0 - SCALE(IR) = 1.D0 -C -C Reclassify the zeroed row as a least squares equation. -C - ITYPE(IR) = 1 - 260 CONTINUE -C -C Reduce ME to reflect any discovered dependent equality -C constraints. -C - ME = JJ - 1 - GO TO 280 - ENDIF - 270 CONTINUE - ENDIF -C -C Try to determine the variables KRANK+1 through L1 from the -C least squares equations. Continue the triangularization with -C pivot element W(ME+1,I). -C - 280 IF (KRANK.LT.L1) THEN - RECALC = .TRUE. -C -C Set FACTOR=ALSQ to remove effect of heavy weight from -C test for column independence. -C - FACTOR = ALSQ - DO 350 I=KRANK+1,L1 -C -C Set IR to point to the ME+1-st row. -C - IR = ME+1 - LEND = L - MEND = M - CALL DWNLT1 (I, L, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, - + W) -C -C Update column SS and find pivot column. -C - CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange. -C Eliminate I-th column below the IR-th element. -C - DO 320 J=M,IR+1,-1 - IF (W(J,I).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), - + W(J,I), SPARAM) - W(J,I) = 0.D0 - CALL SLATEC_DROTM (N+1-I, W(J-1,I+1), MDW, W(J,I+1), - + MDW, SPARAM) - ENDIF - 320 CONTINUE -C -C Test if new pivot element is near zero. -C If so, the column is dependent. -C Then check row norm test to be classified as independent. -C - T = SCALE(IR)*W(IR,I)**2 - INDEP = T .GT. (TAU*EANORM)**2 - IF (INDEP) THEN - RN = 0.D0 - DO 340 I1=IR,M - DO 330 J1=I+1,N - RN = MAX(RN, SCALE(I1)*W(I1,J1)**2) - 330 CONTINUE - 340 CONTINUE - INDEP = T .GT. RN*TAU**2 - ENDIF -C -C If independent, swap the IR-th and KRANK+1-th rows to -C maintain the triangular form. Update the rank indicator -C KRANK and the equality constraint pointer ME. -C - IF (.NOT.INDEP) GO TO 360 - CALL DSWAP(N+1, W(KRANK+1,1), MDW, W(IR,1), MDW) - CALL DSWAP(1, SCALE(KRANK+1), 1, SCALE(IR), 1) -C -C Reclassify the least square equation as an equality -C constraint and rescale it. -C - ITYPE(IR) = 0 - T = SQRT(SCALE(KRANK+1)) - CALL DSCAL(N+1, T, W(KRANK+1,1), MDW) - SCALE(KRANK+1) = ALSQ - ME = ME+1 - KRANK = KRANK+1 - 350 CONTINUE - ENDIF -C -C If pseudorank is less than L, apply Householder transformation. -C from right. -C - 360 IF (KRANK.LT.L) THEN - DO 370 J=KRANK,1,-1 - CALL DH12 (1, J, KRANK+1, L, W(J,1), MDW, H(J), W, MDW, 1, - + J-1) - 370 CONTINUE - ENDIF -C - NIV = KRANK + NSOLN - L - IF (L.EQ.N) DONE = .TRUE. -C -C End of initial triangularization. -C - IDOPE(1) = ME - IDOPE(2) = KRANK - IDOPE(3) = NIV - RETURN - END -*DECK DWNLT1 - SUBROUTINE DWNLT1 (I, LEND, MEND, IR, MDW, RECALC, IMAX, HBAR, H, - + SCALE, W) -C***BEGIN PROLOGUE DWNLT1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLT1-S, DWNLT1-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C To update the column Sum Of Squares and find the pivot column. -C The column Sum of Squares Vector will be updated at each step. -C When numerically necessary, these values will be recomputed. -C -C***SEE ALSO DWNLIT -C***ROUTINES CALLED IDAMAX -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DWNLT1 - - INTEGER I, IMAX, IR, LEND, MDW, MEND - DOUBLE PRECISION H(*), HBAR, SCALE(*), W(MDW,*) - LOGICAL RECALC -C - EXTERNAL IDAMAX - INTEGER IDAMAX -C - INTEGER J, K -C -C***FIRST EXECUTABLE STATEMENT DWNLT1 - IF (IR.NE.1 .AND. (.NOT.RECALC)) THEN -C -C Update column SS=sum of squares. -C - DO 10 J=I,LEND - H(J) = H(J) - SCALE(IR-1)*W(IR-1,J)**2 - 10 CONTINUE -C -C Test for numerical accuracy. -C - IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 - RECALC = (HBAR+1.E-3*H(IMAX)) .EQ. HBAR - ENDIF -C -C If required, recalculate column SS, using rows IR through MEND. -C - IF (RECALC) THEN - DO 30 J=I,LEND - H(J) = 0.D0 - DO 20 K=IR,MEND - H(J) = H(J) + SCALE(K)*W(K,J)**2 - 20 CONTINUE - 30 CONTINUE -C -C Find column with largest SS. -C - IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 - HBAR = H(IMAX) - ENDIF - RETURN - END -*DECK DWNLT2 - LOGICAL FUNCTION DWNLT2 (ME, MEND, IR, FACTOR, TAU, SCALE, WIC) -C***BEGIN PROLOGUE DWNLT2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLT2-S, DWNLT2-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C To test independence of incoming column. -C -C Test the column IC to determine if it is linearly independent -C of the columns already in the basis. In the initial tri. step, -C we usually want the heavy weight ALAMDA to be included in the -C test for independence. In this case, the value of FACTOR will -C have been set to 1.E0 before this procedure is invoked. -C In the potentially rank deficient problem, the value of FACTOR -C will have been set to ALSQ=ALAMDA**2 to remove the effect of the -C heavy weight from the test for independence. -C -C Write new column as partitioned vector -C (A1) number of components in solution so far = NIV -C (A2) M-NIV components -C And compute SN = inverse weighted length of A1 -C RN = inverse weighted length of A2 -C Call the column independent when RN .GT. TAU*SN -C -C***SEE ALSO DWNLIT -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DWNLT2 - - DOUBLE PRECISION FACTOR, SCALE(*), TAU, WIC(*) - INTEGER IR, ME, MEND -C - DOUBLE PRECISION RN, SN, T - INTEGER J -C -C***FIRST EXECUTABLE STATEMENT DWNLT2 - SN = 0.E0 - RN = 0.E0 - DO 10 J=1,MEND - T = SCALE(J) - IF (J.LE.ME) T = T/FACTOR - T = T*WIC(J)**2 -C - IF (J.LT.IR) THEN - SN = SN + T - ELSE - RN = RN + T - ENDIF - 10 CONTINUE - DWNLT2 = RN .GT. SN*TAU**2 - RETURN - END -*DECK DWNLT3 - SUBROUTINE DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C***BEGIN PROLOGUE DWNLT3 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLT3-S, DWNLT3-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Perform column interchange. -C Exchange elements of permuted index vector and perform column -C interchanges. -C -C***SEE ALSO DWNLIT -C***ROUTINES CALLED DSWAP -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DWNLT3 - - INTEGER I, IMAX, IPIVOT(*), M, MDW - DOUBLE PRECISION H(*), W(MDW,*) -C - EXTERNAL DSWAP -C - DOUBLE PRECISION T - INTEGER ITEMP -C -C***FIRST EXECUTABLE STATEMENT DWNLT3 - IF (IMAX.NE.I) THEN - ITEMP = IPIVOT(I) - IPIVOT(I) = IPIVOT(IMAX) - IPIVOT(IMAX) = ITEMP -C - CALL DSWAP(M, W(1,IMAX), 1, W(1,I), 1) -C - T = H(IMAX) - H(IMAX) = H(I) - H(I) = T - ENDIF - RETURN - END diff --git a/extras/delsparsepy/example.py b/extras/delsparsepy/example.py deleted file mode 100644 index c859fd2..0000000 --- a/extras/delsparsepy/example.py +++ /dev/null @@ -1,131 +0,0 @@ - -# Import the Delaunay Fortran code. -import delsparse - -# Return the source point indices and weights associated with a set of -# interpolation points. Takes points in row-major (C style) format. -# -# INPUTS: -# pts -- 2D Numpy array of float64 points, where each row is one point. -# q -- 2D numpy array of float64 points where Delaunay predictions -# are to be made, where each row is one point. -# -# OUTPUT: -# (indices, weights) -- Where "indices" is a 2D NumPy array of integers -# and each row, i, enumerates the indices of rows in "pts" that are -# the vertices of the simplex containing q[i], and each corresponding -# row of weights (a 2D NumPy array of float64) provides the convex -# weights such that q[i] = np.dot(pts[indices[i]], weights[i]). -# -def delaunay_simplex(pts, q, allow_extrapolation=True, print_errors=True, - parallel=True, pmode=None, chain=None, - ibudget=10000, epsilon=2**(-23), check_spacing=False): - # Enable parallelism. - if parallel: - import os - os.environ["OMP_NESTED"] = "TRUE" - # Import NumPy. - import numpy as np - # Get the predictions from VTdelaunay - pts_in = np.asarray(pts.T, dtype=np.float64, order="F") - p_in = np.asarray(q.T, dtype=np.float64, order="F") - simp_out = np.ones(shape=(p_in.shape[0]+1, p_in.shape[1]), - dtype=np.int32, order="F") - weights_out = np.ones(shape=(p_in.shape[0]+1, p_in.shape[1]), - dtype=np.float64, order="F") - error_out = np.ones(shape=(p_in.shape[1],), - dtype=np.int32, order="F") - if parallel: - delsparse.delaunaysparsep(pts_in.shape[0], pts_in.shape[1], - pts_in, p_in.shape[1], p_in, simp_out, - weights_out, error_out, extrap=100.0, - pmode=pmode, ibudget=ibudget, - eps=epsilon, chain=chain, - exact=check_spacing) - else: - delsparse.delaunaysparses(pts_in.shape[0], pts_in.shape[1], - pts_in, p_in.shape[1], p_in, simp_out, - weights_out, error_out, extrap=100.0, - ibudget=ibudget, eps=epsilon, - chain=chain, exact=check_spacing) - # Remove "extrapolation" errors if the user doesn't care. - if allow_extrapolation: error_out = np.where(error_out == 1, 0, error_out) - else: - if 1 in error_out: - class Extrapolation(Exception): pass - raise(Extrapolation("Encountered extrapolation point when making Delaunay prediction.")) - # Handle any errors that may have occurred. - if (sum(error_out) != 0): - if print_errors: - unique_errors = sorted(np.unique(error_out)) - print(" [Delaunay errors:",end="") - for e in unique_errors: - if (e == 0): continue - indices = tuple(str(i) for i in range(len(error_out)) - if (error_out[i] == e)) - if (len(indices) > 5): indices = indices[:2] + ('...',) + indices[-2:] - print(" %3i"%e,"at","{"+",".join(indices)+"}", end=";") - print("] ") - # Reset the errors to simplex of 1s (to be 0) and weights of 0s. - bad_indices = (error_out > (1 if allow_extrapolation else 0)) - simp_out[:,bad_indices] = 1 - weights_out[:,bad_indices] = 0 - # Adjust the output simplices and weights to be expected shape. - indices = simp_out.T - 1 - weights = weights_out.T - # Return the appropriate shaped pair of points and weights - return (indices, weights) - -# This testing code is placed in a `main` block in case someone -# copies this file to use the 'delaunay_simplex' function. -if __name__ == "__main__": - # List out the "help" documentation. - # help(delsparse) - - # Declare some test function. - import numpy as np - f = lambda x: 3*x[0]+.5*np.cos(8*x[0])+np.sin(5*x[-1]) - np.random.seed(0) - - # Generate test data. - d = 2 - test_size = 1000 - train_sizes = (10, 50, 100, 200, 500, 1000, 5000, 10000) - # Construct the "test" data (q, f_q). - q = np.random.random(size=(test_size,d)) - f_q = np.asarray(list(map(f,q)), dtype=float) - # Construct initial "train" data (x, y). - x = np.random.random(size=(train_sizes[0],d)) - y = np.asarray(list(map(f,x)), dtype=float) - - # Construct a function that converts indices and weights into a real number prediction. - def delaunay_approx(q, points, values): - q = np.array(q, dtype=float) - if len(q.shape) == 1: - inds, wts = delaunay_simplex(points.copy(), np.reshape(q,(1,len(q)))) - return np.dot(values[inds[0]], wts[0]) - else: - inds, wts = delaunay_simplex(points.copy(), q) - vals = values[inds.flatten()].reshape(wts.shape) - return np.sum(vals * wts, axis=1) - - # Show convergence by adding more points to the training set. - for n in train_sizes: - # Add more random points to the "training" set. - if (n > len(x)): - new_points = np.random.random(size=(n-len(x),d)) - new_values = np.asarray(list(map(f,new_points)), dtype=float) - x = np.concatenate( (x,new_points), axis=0 ) - y = np.concatenate( (y,new_values) ) - # Approximate at points. - f_hat = delaunay_approx(q, x, y) - # Compute errors. - abs_error = abs(f_hat - f_q) - avg_abs_error = sum(abs_error) / test_size - max_abs_error = max(abs_error) - # Show errors. - print() - print("Train size:", n) - print(" maximum absolute error: %.2f"%(max_abs_error)) - print(" average absolute error: %.2f"%(avg_abs_error)) - diff --git a/src/dependencies/blas.f b/src/dependencies/blas.f deleted file mode 100644 index df991ff..0000000 --- a/src/dependencies/blas.f +++ /dev/null @@ -1,2206 +0,0 @@ - -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* ====================================== - - DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* Purpose: -* ============= -* -* DASUM takes the sum of the absolute values. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 3/93 to return if incx .le. 0. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,M,MP1,NINCX -* .. -* .. Intrinsic Functions .. - INTRINSIC DABS,MOD -* .. - DASUM = 0.0D0 - DTEMP = 0.0D0 - IF (N.LE.0 .OR. INCX.LE.0) RETURN - IF (INCX.EQ.1) THEN -* code for increment equal to 1 -* -* -* clean-up loop -* - M = MOD(N,6) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DTEMP + DABS(DX(I)) - END DO - IF (N.LT.6) THEN - DASUM = DTEMP - RETURN - END IF - END IF - MP1 = M + 1 - DO I = MP1,N,6 - DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) + - $ DABS(DX(I+2)) + DABS(DX(I+3)) + - $ DABS(DX(I+4)) + DABS(DX(I+5)) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - DTEMP = DTEMP + DABS(DX(I)) - END DO - END IF - DASUM = DTEMP - RETURN - END - - SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - DOUBLE PRECISION DA - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* Purpose: -* ============= -* -* DAXPY constant times a vector plus a vector. -* uses unrolled loops for increments equal to one. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DA is DOUBLE PRECISION. On entry, DA specifies the scalar alpha. -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -* -* INCY is INTEGER storage spacing between elements of DY -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (DA.EQ.0.0D0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,4) - IF (M.NE.0) THEN - DO I = 1,M - DY(I) = DY(I) + DA*DX(I) - END DO - END IF - IF (N.LT.4) RETURN - MP1 = M + 1 - DO I = MP1,N,4 - DY(I) = DY(I) + DA*DX(I) - DY(I+1) = DY(I+1) + DA*DX(I+1) - DY(I+2) = DY(I+2) + DA*DX(I+2) - DY(I+3) = DY(I+3) + DA*DX(I+3) - END DO - ELSE -* -* code for unequal increments or equal increments -* 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 I = 1,N - DY(IY) = DY(IY) + DA*DX(IX) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN - END - - SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* Purpose: -* ============= -* -* DCOPY copies a vector, x, to a vector, y. -* uses unrolled loops for increments equal to 1. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -* -* INCY is INTEGER storage spacing between elements of DY -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,7) - IF (M.NE.0) THEN - DO I = 1,M - DY(I) = DX(I) - END DO - IF (N.LT.7) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,7 - DY(I) = DX(I) - DY(I+1) = DX(I+1) - DY(I+2) = DX(I+2) - DY(I+3) = DX(I+3) - DY(I+4) = DX(I+4) - DY(I+5) = DX(I+5) - DY(I+6) = DX(I+6) - END DO - ELSE -* -* code for unequal increments or equal increments -* 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 I = 1,N - DY(IY) = DX(IX) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN - END - - DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* Purpose: -* ============= -* -* DDOT forms the dot product of two vectors. -* uses unrolled loops for increments equal to one. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -* -* INCY is INTEGER storage spacing between elements of DY -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - DDOT = 0.0D0 - DTEMP = 0.0D0 - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,5) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DTEMP + DX(I)*DY(I) - END DO - IF (N.LT.5) THEN - DDOT=DTEMP - RETURN - END IF - END IF - MP1 = M + 1 - DO I = MP1,N,5 - DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) + - $ DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) - END DO - ELSE -* -* code for unequal increments or equal increments -* 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 I = 1,N - DTEMP = DTEMP + DX(IX)*DY(IY) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - DDOT = DTEMP - RETURN - END - - SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* -- Reference BLAS level3 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of -* Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER K,LDA,LDB,LDC,M,N - CHARACTER TRANSA,TRANSB -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB - LOGICAL NOTA,NOTB -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Set NOTA and NOTB as true if A and B respectively are -* not -* transposed and set NROWA, NCOLA and NROWB as the number of -* rows -* and columns of A and the number of rows of B -* respectively. -* - NOTA = LSAME(TRANSA,'N') - NOTB = LSAME(TRANSB,'N') - IF (NOTA) THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - END IF - IF (NOTB) THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. - + (.NOT.LSAME(TRANSA,'T'))) THEN - INFO = 1 - ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. - + (.NOT.LSAME(TRANSB,'T'))) THEN - INFO = 2 - ELSE IF (M.LT.0) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (K.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 8 - ELSE IF (LDB.LT.MAX(1,NROWB)) THEN - INFO = 10 - ELSE IF (LDC.LT.MAX(1,M)) THEN - INFO = 13 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGEMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN -* -* And if alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,M - C(I,J) = BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF (NOTB) THEN - IF (NOTA) THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 50 I = 1,M - C(I,J) = ZERO - 50 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 60 I = 1,M - C(I,J) = BETA*C(I,J) - 60 CONTINUE - END IF - DO 80 L = 1,K - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - ELSE -* -* Form C := alpha*A**T*B + beta*C -* - DO 120 J = 1,N - DO 110 I = 1,M - TEMP = ZERO - DO 100 L = 1,K - TEMP = TEMP + A(L,I)*B(L,J) - 100 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 110 CONTINUE - 120 CONTINUE - END IF - ELSE - IF (NOTA) THEN -* -* Form C := alpha*A*B**T + beta*C -* - DO 170 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 130 I = 1,M - C(I,J) = ZERO - 130 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 140 I = 1,M - C(I,J) = BETA*C(I,J) - 140 CONTINUE - END IF - DO 160 L = 1,K - TEMP = ALPHA*B(J,L) - DO 150 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - ELSE -* -* Form C := alpha*A**T*B**T + beta*C -* - DO 200 J = 1,N - DO 190 I = 1,M - TEMP = ZERO - DO 180 L = 1,K - TEMP = TEMP + A(L,I)*B(J,L) - 180 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 190 CONTINUE - 200 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMM . -* - END - - SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* -- Reference BLAS level2 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER INCX,INCY,LDA,M,N - CHARACTER TRANS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* Purpose: -* ============= -* -* DGEMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n matrix. -* -* Arguments: -* ========== -* -* TRANS is CHARACTER*1 -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. -* M is INTEGER -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* -* N is INTEGER -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* -* ALPHA is DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* -* A is DOUBLE PRECISION array, dimension ( LDA, N ) -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. -* -* LDA is INTEGER -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* -* X is DOUBLE PRECISION array, dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* -* INCX is INTEGER -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* -* BETA is DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* -* Y is DOUBLE PRECISION array, dimension at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry with BETA non-zero, the incremented array Y -* must contain the vector y. On exit, Y is overwritten by the -* updated vector y. -* -* INCY is INTEGER -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* -* Further Details: -* ===================== -* -* Level 2 Blas routine. -* The vector and matrix arguments are not referenced when N = 0, or M = 0 -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 1 - ELSE IF (M.LT.0) THEN - INFO = 2 - ELSE IF (N.LT.0) THEN - INFO = 3 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - ELSE IF (INCY.EQ.0) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGEMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF (LSAME(TRANS,'N')) THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (LENX-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (LENY-1)*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF (BETA.NE.ONE) THEN - IF (INCY.EQ.1) THEN - IF (BETA.EQ.ZERO) THEN - DO 10 I = 1,LENY - Y(I) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1,LENY - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ELSE - IY = KY - IF (BETA.EQ.ZERO) THEN - DO 30 I = 1,LENY - Y(IY) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1,LENY - Y(IY) = BETA*Y(IY) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF (ALPHA.EQ.ZERO) RETURN - IF (LSAME(TRANS,'N')) THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF (INCY.EQ.1) THEN - DO 60 J = 1,N - TEMP = ALPHA*X(JX) - DO 50 I = 1,M - Y(I) = Y(I) + TEMP*A(I,J) - 50 CONTINUE - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80 J = 1,N - TEMP = ALPHA*X(JX) - IY = KY - DO 70 I = 1,M - Y(IY) = Y(IY) + TEMP*A(I,J) - IY = IY + INCY - 70 CONTINUE - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A**T*x + y. -* - JY = KY - IF (INCX.EQ.1) THEN - DO 100 J = 1,N - TEMP = ZERO - DO 90 I = 1,M - TEMP = TEMP + A(I,J)*X(I) - 90 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120 J = 1,N - TEMP = ZERO - IX = KX - DO 110 I = 1,M - TEMP = TEMP + A(I,J)*X(IX) - IX = IX + INCX - 110 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMV . -* - END - - SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* -- Reference BLAS level2 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of -* Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX,INCY,LDA,M,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER(ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,J,JY,KX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (M.LT.0) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (INCX.EQ.0) THEN - INFO = 5 - ELSE IF (INCY.EQ.0) THEN - INFO = 7 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGER ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (INCY.GT.0) THEN - JY = 1 - ELSE - JY = 1 - (N-1)*INCY - END IF - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*Y(JY) - DO 10 I = 1,M - A(I,J) = A(I,J) + X(I)*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (M-1)*INCX - END IF - DO 40 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*Y(JY) - IX = KX - DO 30 I = 1,M - A(I,J) = A(I,J) + X(IX)*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of DGER . -* - END - - DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION X(*) -* .. -* -* Purpose: -* ============= -* -* DNRM2 returns the euclidean norm of a vector via the function -* name, so that -* -* DNRM2 := sqrt( x'*x ) -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* Further Details: -* ===================== -* -* -- This version written on 25-October-1982. -* Modified on 14-October-1993 to inline the call to DLASSQ. -* Sven Hammarling, Nag Ltd. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ - INTEGER IX -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS,SQRT -* .. - IF (N.LT.1 .OR. INCX.LT.1) THEN - NORM = ZERO - ELSE IF (N.EQ.1) THEN - NORM = ABS(X(1)) - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10 IX = 1,1 + (N-1)*INCX,INCX - IF (X(IX).NE.ZERO) THEN - ABSXI = ABS(X(IX)) - IF (SCALE.LT.ABSXI) THEN - SSQ = ONE + SSQ* (SCALE/ABSXI)**2 - SCALE = ABSXI - ELSE - SSQ = SSQ + (ABSXI/SCALE)**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE*SQRT(SSQ) - END IF -* - DNRM2 = NORM - RETURN -* -* End of DNRM2. -* - END - - SUBROUTINE DSCAL(N,DA,DX,INCX) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - DOUBLE PRECISION DA - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* Purpose: -* ============= -* -* DSCAL scales a vector by a constant. -* uses unrolled loops for increment equal to 1. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DA is DOUBLE PRECISION On entry, DA specifies the scalar alpha. -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 3/93 to return if incx .le. 0. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,M,MP1,NINCX -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0 .OR. INCX.LE.0) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* -* -* clean-up loop -* - M = MOD(N,5) - IF (M.NE.0) THEN - DO I = 1,M - DX(I) = DA*DX(I) - END DO - IF (N.LT.5) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,5 - DX(I) = DA*DX(I) - DX(I+1) = DA*DX(I+1) - DX(I+2) = DA*DX(I+2) - DX(I+3) = DA*DX(I+3) - DX(I+4) = DA*DX(I+4) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - DX(I) = DA*DX(I) - END DO - END IF - RETURN - END - - SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* Purpose: -* ============= -* -* DSWAP interchanges two vectors. -* uses unrolled loops for increments equal to 1. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -* -* INCY is INTEGER storage spacing between elements of DY -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,3) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - END DO - IF (N.LT.3) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,3 - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - DTEMP = DX(I+1) - DX(I+1) = DY(I+1) - DY(I+1) = DTEMP - DTEMP = DX(I+2) - DX(I+2) = DY(I+2) - DY(I+2) = DTEMP - END DO - ELSE -* -* code for unequal increments or equal increments 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 I = 1,N - DTEMP = DX(IX) - DX(IX) = DY(IY) - DY(IY) = DTEMP - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN - END - - SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* -- Reference BLAS level3 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of -* Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER LDA,LDB,M,N - CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,K,NROWA - LOGICAL LSIDE,NOUNIT,UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Test the input parameters. -* - LSIDE = LSAME(SIDE,'L') - IF (LSIDE) THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME(DIAG,'N') - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN - INFO = 1 - ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 2 - ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. - + (.NOT.LSAME(TRANSA,'T')) .AND. - + (.NOT.LSAME(TRANSA,'C'))) THEN - INFO = 3 - ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN - INFO = 4 - ELSE IF (M.LT.0) THEN - INFO = 5 - ELSE IF (N.LT.0) THEN - INFO = 6 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDB.LT.MAX(1,M)) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (M.EQ.0 .OR. N.EQ.0) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - B(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF (LSIDE) THEN - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*A*B. -* - IF (UPPER) THEN - DO 50 J = 1,N - DO 40 K = 1,M - IF (B(K,J).NE.ZERO) THEN - TEMP = ALPHA*B(K,J) - DO 30 I = 1,K - 1 - B(I,J) = B(I,J) + TEMP*A(I,K) - 30 CONTINUE - IF (NOUNIT) TEMP = TEMP*A(K,K) - B(K,J) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80 J = 1,N - DO 70 K = M,1,-1 - IF (B(K,J).NE.ZERO) THEN - TEMP = ALPHA*B(K,J) - B(K,J) = TEMP - IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) - DO 60 I = K + 1,M - B(I,J) = B(I,J) + TEMP*A(I,K) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A**T*B. -* - IF (UPPER) THEN - DO 110 J = 1,N - DO 100 I = M,1,-1 - TEMP = B(I,J) - IF (NOUNIT) TEMP = TEMP*A(I,I) - DO 90 K = 1,I - 1 - TEMP = TEMP + A(K,I)*B(K,J) - 90 CONTINUE - B(I,J) = ALPHA*TEMP - 100 CONTINUE - 110 CONTINUE - ELSE - DO 140 J = 1,N - DO 130 I = 1,M - TEMP = B(I,J) - IF (NOUNIT) TEMP = TEMP*A(I,I) - DO 120 K = I + 1,M - TEMP = TEMP + A(K,I)*B(K,J) - 120 CONTINUE - B(I,J) = ALPHA*TEMP - 130 CONTINUE - 140 CONTINUE - END IF - END IF - ELSE - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*B*A. -* - IF (UPPER) THEN - DO 180 J = N,1,-1 - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 150 I = 1,M - B(I,J) = TEMP*B(I,J) - 150 CONTINUE - DO 170 K = 1,J - 1 - IF (A(K,J).NE.ZERO) THEN - TEMP = ALPHA*A(K,J) - DO 160 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - ELSE - DO 220 J = 1,N - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 190 I = 1,M - B(I,J) = TEMP*B(I,J) - 190 CONTINUE - DO 210 K = J + 1,N - IF (A(K,J).NE.ZERO) THEN - TEMP = ALPHA*A(K,J) - DO 200 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 200 CONTINUE - END IF - 210 CONTINUE - 220 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A**T. -* - IF (UPPER) THEN - DO 260 K = 1,N - DO 240 J = 1,K - 1 - IF (A(J,K).NE.ZERO) THEN - TEMP = ALPHA*A(J,K) - DO 230 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 230 CONTINUE - END IF - 240 CONTINUE - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(K,K) - IF (TEMP.NE.ONE) THEN - DO 250 I = 1,M - B(I,K) = TEMP*B(I,K) - 250 CONTINUE - END IF - 260 CONTINUE - ELSE - DO 300 K = N,1,-1 - DO 280 J = K + 1,N - IF (A(J,K).NE.ZERO) THEN - TEMP = ALPHA*A(J,K) - DO 270 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 270 CONTINUE - END IF - 280 CONTINUE - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(K,K) - IF (TEMP.NE.ONE) THEN - DO 290 I = 1,M - B(I,K) = TEMP*B(I,K) - 290 CONTINUE - END IF - 300 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMM . -* - END - - SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* -- Reference BLAS level2 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of -* Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER INCX,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER(ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,J,JX,KX - LOGICAL NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := A*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - DO 10 I = 1,J - 1 - X(I) = X(I) + TEMP*A(I,J) - 10 CONTINUE - IF (NOUNIT) X(J) = X(J)*A(J,J) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 30 I = 1,J - 1 - X(IX) = X(IX) + TEMP*A(I,J) - IX = IX + INCX - 30 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*A(J,J) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - DO 50 I = N,J + 1,-1 - X(I) = X(I) + TEMP*A(I,J) - 50 CONTINUE - IF (NOUNIT) X(J) = X(J)*A(J,J) - END IF - 60 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 80 J = N,1,-1 - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 70 I = N,J + 1,-1 - X(IX) = X(IX) + TEMP*A(I,J) - IX = IX - INCX - 70 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*A(J,J) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A**T*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 100 J = N,1,-1 - TEMP = X(J) - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 90 I = J - 1,1,-1 - TEMP = TEMP + A(I,J)*X(I) - 90 CONTINUE - X(J) = TEMP - 100 CONTINUE - ELSE - JX = KX + (N-1)*INCX - DO 120 J = N,1,-1 - TEMP = X(JX) - IX = JX - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 110 I = J - 1,1,-1 - IX = IX - INCX - TEMP = TEMP + A(I,J)*X(IX) - 110 CONTINUE - X(JX) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 140 J = 1,N - TEMP = X(J) - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 130 I = J + 1,N - TEMP = TEMP + A(I,J)*X(I) - 130 CONTINUE - X(J) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160 J = 1,N - TEMP = X(JX) - IX = JX - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 150 I = J + 1,N - IX = IX + INCX - TEMP = TEMP + A(I,J)*X(IX) - 150 CONTINUE - X(JX) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMV . -* - END - - SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* -- Reference BLAS level3 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER LDA,LDB,M,N - CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*) -* .. -* -* Purpose: -* ============= -* -* DTRSM solves one of the matrix equations -* -* op( A )*X = alpha*B, or X*op( A ) = alpha*B, -* -* where alpha is a scalar, X and B are m by n matrices, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A**T. -* -* The matrix X is overwritten on B. -* -* Arguments: -* ========== -* -* SIDE is CHARACTER*1 -* On entry, SIDE specifies whether op( A ) appears on the left -* or right of X as follows: -* -* SIDE = 'L' or 'l' op( A )*X = alpha*B. -* -* SIDE = 'R' or 'r' X*op( A ) = alpha*B. -* -* UPLO is CHARACTER*1 -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* TRANSA is CHARACTER*1 -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n' op( A ) = A. -* -* TRANSA = 'T' or 't' op( A ) = A**T. -* -* TRANSA = 'C' or 'c' op( A ) = A**T. -* -* DIAG is CHARACTER*1 -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* M is INTEGER -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* -* N is INTEGER -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* -* ALPHA is DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* -* A is DOUBLE PRECISION array, dimension ( LDA, k ), -* where k is m when SIDE = 'L' or 'l' -* and k is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* -* LDA is INTEGER -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* -* B is DOUBLE PRECISION array, dimension ( LDB, N ) -* Before entry, the leading m by n part of the array B must -* contain the right-hand side matrix B, and on exit is -* overwritten by the solution matrix X. -* -* LDB is INTEGER -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* -* Further Details: -* ===================== -* -* Level 3 Blas routine. -* -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,K,NROWA - LOGICAL LSIDE,NOUNIT,UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Test the input parameters. -* - LSIDE = LSAME(SIDE,'L') - IF (LSIDE) THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME(DIAG,'N') - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN - INFO = 1 - ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 2 - ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. - + (.NOT.LSAME(TRANSA,'T')) .AND. - + (.NOT.LSAME(TRANSA,'C'))) THEN - INFO = 3 - ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN - INFO = 4 - ELSE IF (M.LT.0) THEN - INFO = 5 - ELSE IF (N.LT.0) THEN - INFO = 6 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDB.LT.MAX(1,M)) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRSM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (M.EQ.0 .OR. N.EQ.0) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - B(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF (LSIDE) THEN - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*inv( A )*B. -* - IF (UPPER) THEN - DO 60 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 30 I = 1,M - B(I,J) = ALPHA*B(I,J) - 30 CONTINUE - END IF - DO 50 K = M,1,-1 - IF (B(K,J).NE.ZERO) THEN - IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) - DO 40 I = 1,K - 1 - B(I,J) = B(I,J) - B(K,J)*A(I,K) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 70 I = 1,M - B(I,J) = ALPHA*B(I,J) - 70 CONTINUE - END IF - DO 90 K = 1,M - IF (B(K,J).NE.ZERO) THEN - IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) - DO 80 I = K + 1,M - B(I,J) = B(I,J) - B(K,J)*A(I,K) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A**T )*B. -* - IF (UPPER) THEN - DO 130 J = 1,N - DO 120 I = 1,M - TEMP = ALPHA*B(I,J) - DO 110 K = 1,I - 1 - TEMP = TEMP - A(K,I)*B(K,J) - 110 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(I,I) - B(I,J) = TEMP - 120 CONTINUE - 130 CONTINUE - ELSE - DO 160 J = 1,N - DO 150 I = M,1,-1 - TEMP = ALPHA*B(I,J) - DO 140 K = I + 1,M - TEMP = TEMP - A(K,I)*B(K,J) - 140 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(I,I) - B(I,J) = TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*B*inv( A ). -* - IF (UPPER) THEN - DO 210 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 170 I = 1,M - B(I,J) = ALPHA*B(I,J) - 170 CONTINUE - END IF - DO 190 K = 1,J - 1 - IF (A(K,J).NE.ZERO) THEN - DO 180 I = 1,M - B(I,J) = B(I,J) - A(K,J)*B(I,K) - 180 CONTINUE - END IF - 190 CONTINUE - IF (NOUNIT) THEN - TEMP = ONE/A(J,J) - DO 200 I = 1,M - B(I,J) = TEMP*B(I,J) - 200 CONTINUE - END IF - 210 CONTINUE - ELSE - DO 260 J = N,1,-1 - IF (ALPHA.NE.ONE) THEN - DO 220 I = 1,M - B(I,J) = ALPHA*B(I,J) - 220 CONTINUE - END IF - DO 240 K = J + 1,N - IF (A(K,J).NE.ZERO) THEN - DO 230 I = 1,M - B(I,J) = B(I,J) - A(K,J)*B(I,K) - 230 CONTINUE - END IF - 240 CONTINUE - IF (NOUNIT) THEN - TEMP = ONE/A(J,J) - DO 250 I = 1,M - B(I,J) = TEMP*B(I,J) - 250 CONTINUE - END IF - 260 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A**T ). -* - IF (UPPER) THEN - DO 310 K = N,1,-1 - IF (NOUNIT) THEN - TEMP = ONE/A(K,K) - DO 270 I = 1,M - B(I,K) = TEMP*B(I,K) - 270 CONTINUE - END IF - DO 290 J = 1,K - 1 - IF (A(J,K).NE.ZERO) THEN - TEMP = A(J,K) - DO 280 I = 1,M - B(I,J) = B(I,J) - TEMP*B(I,K) - 280 CONTINUE - END IF - 290 CONTINUE - IF (ALPHA.NE.ONE) THEN - DO 300 I = 1,M - B(I,K) = ALPHA*B(I,K) - 300 CONTINUE - END IF - 310 CONTINUE - ELSE - DO 360 K = 1,N - IF (NOUNIT) THEN - TEMP = ONE/A(K,K) - DO 320 I = 1,M - B(I,K) = TEMP*B(I,K) - 320 CONTINUE - END IF - DO 340 J = K + 1,N - IF (A(J,K).NE.ZERO) THEN - TEMP = A(J,K) - DO 330 I = 1,M - B(I,J) = B(I,J) - TEMP*B(I,K) - 330 CONTINUE - END IF - 340 CONTINUE - IF (ALPHA.NE.ONE) THEN - DO 350 I = 1,M - B(I,K) = ALPHA*B(I,K) - 350 CONTINUE - END IF - 360 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSM . -* - END - - INTEGER FUNCTION IDAMAX(N,DX,INCX) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* Purpose: -* ============= -* -* IDAMAX finds the index of the first element having maximum absolute value. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of SX -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 3/93 to return if incx .le. 0. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DMAX - INTEGER I,IX -* .. -* .. Intrinsic Functions .. - INTRINSIC DABS -* .. - IDAMAX = 0 - IF (N.LT.1 .OR. INCX.LE.0) RETURN - IDAMAX = 1 - IF (N.EQ.1) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* - DMAX = DABS(DX(1)) - DO I = 2,N - IF (DABS(DX(I)).GT.DMAX) THEN - IDAMAX = I - DMAX = DABS(DX(I)) - END IF - END DO - ELSE -* -* code for increment not equal to 1 -* - IX = 1 - DMAX = DABS(DX(1)) - IX = IX + INCX - DO I = 2,N - IF (DABS(DX(IX)).GT.DMAX) THEN - IDAMAX = I - DMAX = DABS(DX(IX)) - END IF - IX = IX + INCX - END DO - END IF - RETURN - END - - LOGICAL FUNCTION LSAME(CA,CB) -* -* -- Reference BLAS level1 routine (version 3.1) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - CHARACTER CA,CB -* .. -* -* Purpose: -* ============= -* -* LSAME returns .TRUE. if CA is the same letter as CB regardless of -* case. -* -* Arguments: -* ========== -* -* CA is CHARACTER*1 -* CB is CHARACTER*1 -* CA and CB specify the single characters to be compared. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ICHAR -* .. -* .. Local Scalars .. - INTEGER INTA,INTB,ZCODE -* .. -* -* Test if the characters are equal -* - LSAME = CA .EQ. CB - IF (LSAME) RETURN -* -* Now test for equivalence if both characters are alphabetic. -* - ZCODE = ICHAR('Z') -* -* Use 'Z' rather than 'A' so that ASCII can be detected on Prime -* machines, on which ICHAR returns a value with bit 8 set. -* ICHAR('A') on Prime machines returns 193 which is the same as -* ICHAR('A') on an EBCDIC machine. -* - INTA = ICHAR(CA) - INTB = ICHAR(CB) -* - IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN -* -* ASCII is assumed - ZCODE is the ASCII code of either lower or -* upper case 'Z'. -* - IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 - IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 -* - ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN -* -* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or -* upper case 'Z'. -* - IF (INTA.GE.129 .AND. INTA.LE.137 .OR. - + INTA.GE.145 .AND. INTA.LE.153 .OR. - + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 - IF (INTB.GE.129 .AND. INTB.LE.137 .OR. - + INTB.GE.145 .AND. INTB.LE.153 .OR. - + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 -* - ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN -* -* ASCII is assumed, on Prime machines - ZCODE is the ASCII code -* plus 128 of either lower or upper case 'Z'. -* - IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 - IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 - END IF - LSAME = INTA .EQ. INTB -* -* RETURN -* -* End of LSAME -* - END - - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* -- Reference BLAS level1 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - CHARACTER*(*) SRNAME - INTEGER INFO -* .. -* -* Purpose: -* ============= -* -* XERBLA is an error handler for the LAPACK routines. -* It is called by an LAPACK routine if an input parameter has an -* invalid value. A message is printed and execution stops. -* -* Installers may consider modifying the STOP statement in order to -* call system-specific exception-handling facilities. -* -* Arguments: -* ========== -* -* SRNAME is CHARACTER*(*) -* The name of the routine which called XERBLA. -* -* INFO is INTEGER -* The position of the invalid parameter in the parameter list -* of the calling routine. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC LEN_TRIM -* .. -* .. Executable Statements .. -* - WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO -* - STOP -* - 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', - $ 'an illegal value' ) -* -* End of XERBLA -* - END - diff --git a/src/dependencies/lapack.f b/src/dependencies/lapack.f deleted file mode 100644 index 3dff8b8..0000000 --- a/src/dependencies/lapack.f +++ /dev/null @@ -1,4369 +0,0 @@ - SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine (version 3.7.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -* -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER INB, INBMIN, IXOVER - PARAMETER( INB = 1, INBMIN = 2, IXOVER = 3 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, - $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN -* .. -* .. External Subroutines .. - EXTERNAL DGEQRF, DLAQP2, DLAQPS, DORMQR, DSWAP, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - DOUBLE PRECISION DNRM2 - EXTERNAL ILAENV, DNRM2 -* .. -* .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test input arguments -* ==================== -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF -* - IF( INFO.EQ.0 ) THEN - MINMN = MIN( M, N ) - IF( MINMN.EQ.0 ) THEN - IWS = 1 - LWKOPT = 1 - ELSE - IWS = 3*N + 1 - NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) - LWKOPT = 2*N + ( N + 1 )*NB - END IF - WORK( 1 ) = LWKOPT -* - IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQP3', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Move initial columns up front. -* - NFXD = 1 - DO 10 J = 1, N - IF( JPVT( J ).NE.0 ) THEN - IF( J.NE.NFXD ) THEN - CALL DSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 ) - JPVT( J ) = JPVT( NFXD ) - JPVT( NFXD ) = J - ELSE - JPVT( J ) = J - END IF - NFXD = NFXD + 1 - ELSE - JPVT( J ) = J - END IF - 10 CONTINUE - NFXD = NFXD - 1 -* -* Factorize fixed columns -* ======================= -* -* Compute the QR factorization of fixed columns and update -* remaining columns. -* - IF( NFXD.GT.0 ) THEN - NA = MIN( M, NFXD ) -*CC CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) - CALL DGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO ) - IWS = MAX( IWS, INT( WORK( 1 ) ) ) - IF( NA.LT.N ) THEN -*CC CALL DORM2R( 'LEFT', 'TRANSPOSE', M, N-NA, NA, A, LDA, -*CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) - CALL DORMQR( 'LEFT', 'TRANSPOSE', M, N-NA, NA, A, LDA, TAU, - $ A( 1, NA+1 ), LDA, WORK, LWORK, INFO ) - IWS = MAX( IWS, INT( WORK( 1 ) ) ) - END IF - END IF -* -* Factorize free columns -* ====================== -* - IF( NFXD.LT.MINMN ) THEN -* - SM = M - NFXD - SN = N - NFXD - SMINMN = MINMN - NFXD -* -* Determine the block size. -* - NB = ILAENV( INB, 'DGEQRF', ' ', SM, SN, -1, -1 ) - NBMIN = 2 - NX = 0 -* - IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN -* -* Determine when to cross over from blocked to unblocked -* code. -* - NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', SM, SN, -1, - $ -1 ) ) -* -* - IF( NX.LT.SMINMN ) THEN -* -* Determine if workspace is large enough for blocked code. -* - MINWS = 2*SN + ( SN+1 )*NB - IWS = MAX( IWS, MINWS ) - IF( LWORK.LT.MINWS ) THEN -* -* Not enough workspace to use optimal NB: Reduce NB and -* determine the minimum value of NB. -* - NB = ( LWORK-2*SN ) / ( SN+1 ) - NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', SM, N, - $ -1, -1 ) ) -* -* - END IF - END IF - END IF -* -* Initialize partial column norms. The first N elements of work -* store the exact column norms. -* - DO 20 J = NFXD + 1, N - WORK( J ) = DNRM2( SM, A( NFXD+1, J ), 1 ) - WORK( N+J ) = WORK( J ) - 20 CONTINUE -* - IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. - $ ( NX.LT.SMINMN ) ) THEN -* -* Use blocked code initially. -* - J = NFXD + 1 -* -* Compute factorization: while loop. -* -* - TOPBMN = MINMN - NX - 30 CONTINUE - IF( J.LE.TOPBMN ) THEN - JB = MIN( NB, TOPBMN-J+1 ) -* -* Factorize JB columns among columns J:N. -* - CALL DLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, - $ JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ), - $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 ) -* - J = J + FJB - GO TO 30 - END IF - ELSE - J = NFXD + 1 - END IF -* -* Use unblocked code to factor the last or only block. -* -* - IF( J.LE.MINMN ) - $ CALL DLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), - $ TAU( J ), WORK( J ), WORK( N+J ), - $ WORK( 2*N+1 ) ) -* - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DGEQP3 -* - END - SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGEQR2 computes a QR factorization of a real m by n matrix A: -* A = Q * R. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix A. -* On exit, the elements on and above the diagonal of the array -* contain the min(m,n) by n upper trapezoidal matrix R (R is -* upper triangular if m >= n); the elements below the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of elementary reflectors (see Further Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(1) H(2) . . . H(k), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v**T -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, K - DOUBLE PRECISION AII -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQR2', -INFO ) - RETURN - END IF -* - K = MIN( M, N ) -* - DO 10 I = 1, K -* -* Generate elementary reflector H(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAU( I ) ) - IF( I.LT.N ) THEN -* -* Apply H(i) to A(i:m,i+1:n) from the left -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = AII - END IF - 10 CONTINUE - RETURN -* -* End of DGEQR2 -* - END - SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGEQRF computes a QR factorization of a real M-by-N matrix A: -* A = Q * R. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix A. -* On exit, the elements on and above the diagonal of the array -* contain the min(M,N)-by-N upper trapezoidal matrix R (R is -* upper triangular if m >= n); the elements below the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of min(m,n) elementary reflectors (see Further -* Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension -* (MAX(1,LWORK)) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is -* the optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(1) H(2) . . . H(k), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v**T -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQRF', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, - $ -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code initially -* - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -* -* Compute the QR factorization of the current block -* A(i:m,i:i+ib-1) -* - CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H**T to A(i:m,i+ib:n) from the left -* - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF - 10 CONTINUE - ELSE - I = 1 - END IF -* -* Use unblocked code to factor the last or only block. -* - IF( I.LE.K ) - $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* - WORK( 1 ) = IWS - RETURN -* -* End of DGEQRF -* - END - SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETF2 computes an LU factorization of a general m-by-n matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, U(k,k) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION SFMIN - INTEGER I, J, JP -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - INTEGER IDAMAX - EXTERNAL DLAMCH, IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DGER, DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Compute machine safe minimum -* - SFMIN = DLAMCH('S') -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP - IF( A( JP, J ).NE.ZERO ) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* Compute elements J+1:M of J-th column. -* - IF( J.LT.M ) THEN - IF( ABS(A( J, J )) .GE. SFMIN ) THEN - CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) - ELSE - DO 20 I = 1, M-J - A( J+I, J ) = A( J+I, J ) / A( J, J ) - 20 CONTINUE - END IF - END IF -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, - $ A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of DGETF2 -* - END - SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETRF computes an LU factorization of a general M-by-N matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL DGETF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGETRF -* - END - SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGETRS solves a system of linear equations -* A * X = B or A**T * X = B -* with a general N-by-N matrix A using the LU factorization computed -* by DGETRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A**T* X = B (Transpose) -* = 'C': A**T* X = B (Conjugate transpose = Transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The factors L and U from the factorization A = P*L*U -* as computed by DGETRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from DGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLASWP, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( NOTRAN ) THEN -* -* Solve A * X = B. -* -* Apply row interchanges to the right hand sides. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A**T * X = B. -* -* Solve U**T *X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve L**T *X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of DGETRS -* - END - DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. -* -* Purpose -* ======= -* -* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary -* overflow. -* -* Arguments -* ========= -* -* X (input) DOUBLE PRECISION -* Y (input) DOUBLE PRECISION -* X and Y specify the values x and y. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION W, XABS, YABS, Z -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - XABS = ABS( X ) - YABS = ABS( Y ) - W = MAX( XABS, YABS ) - Z = MIN( XABS, YABS ) - IF( Z.EQ.ZERO ) THEN - DLAPY2 = W - ELSE - DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) - END IF - RETURN -* -* End of DLAPY2 -* - END - SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, - $ WORK ) -* -* -- LAPACK auxiliary routine (version 3.7.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -* -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER LDA, M, N, OFFSET -* .. -* .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), - $ WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, ITEMP, J, MN, OFFPI, PVT - DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, DSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DNRM2 - EXTERNAL IDAMAX, DLAMCH, DNRM2 -* .. -* .. Executable Statements .. -* - MN = MIN( M-OFFSET, N ) - TOL3Z = SQRT(DLAMCH('EPSILON')) -* -* Compute factorization. -* - DO 20 I = 1, MN -* - OFFPI = OFFSET + I -* -* Determine ith pivot column and swap if necessary. -* - PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 ) -* - IF( PVT.NE.I ) THEN - CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) - ITEMP = JPVT( PVT ) - JPVT( PVT ) = JPVT( I ) - JPVT( I ) = ITEMP - VN1( PVT ) = VN1( I ) - VN2( PVT ) = VN2( I ) - END IF -* -* Generate elementary reflector H(i). -* - IF( OFFPI.LT.M ) THEN - CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, - $ TAU( I ) ) - ELSE - CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) - END IF -* - IF( I.LT.N ) THEN -* -* Apply H(i)**T to A(offset+i:m,i+1:n) from the left. -* - AII = A( OFFPI, I ) - A( OFFPI, I ) = ONE - CALL DLARF( 'LEFT', M-OFFPI+1, N-I, A( OFFPI, I ), 1, - $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) - A( OFFPI, I ) = AII - END IF -* -* Update partial column norms. -* - DO 10 J = I + 1, N - IF( VN1( J ).NE.ZERO ) THEN -* -* NOTE: The following 4 lines follow from the analysis in -* Lapack Working Note 176. -* - TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 - IF( TEMP2 .LE. TOL3Z ) THEN - IF( OFFPI.LT.M ) THEN - VN1( J ) = DNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) - VN2( J ) = VN1( J ) - ELSE - VN1( J ) = ZERO - VN2( J ) = ZERO - END IF - ELSE - VN1( J ) = VN1( J )*SQRT( TEMP ) - END IF - END IF - 10 CONTINUE -* - 20 CONTINUE -* - RETURN -* -* End of DLAQP2 -* - END - SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, - $ VN2, AUXV, F, LDF ) -* -* -- LAPACK auxiliary routine (version 3.7.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -* -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER KB, LDA, LDF, M, N, NB, OFFSET -* .. -* .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), - $ VN1( * ), VN2( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK - DOUBLE PRECISION AKK, TEMP, TEMP2, TOL3Z -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, NINT, SQRT -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DNRM2 - EXTERNAL IDAMAX, DLAMCH, DNRM2 -* .. -* .. Executable Statements .. -* - LASTRK = MIN( M, N+OFFSET ) - LSTICC = 0 - K = 0 - TOL3Z = SQRT(DLAMCH('EPSILON')) -* -* Beginning of while loop. -* - 10 CONTINUE - IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN - K = K + 1 - RK = OFFSET + K -* -* Determine ith pivot column and swap if necessary -* - PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) - IF( PVT.NE.K ) THEN - CALL DSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 ) - CALL DSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF ) - ITEMP = JPVT( PVT ) - JPVT( PVT ) = JPVT( K ) - JPVT( K ) = ITEMP - VN1( PVT ) = VN1( K ) - VN2( PVT ) = VN2( K ) - END IF -* -* Apply previous Householder reflectors to column K: -* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**T. -* - IF( K.GT.1 ) THEN - CALL DGEMV( 'NO TRANSPOSE', M-RK+1, K-1, -ONE, A( RK, 1 ), - $ LDA, F( K, 1 ), LDF, ONE, A( RK, K ), 1 ) - END IF -* -* Generate elementary reflector H(k). -* - IF( RK.LT.M ) THEN - CALL DLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) - ELSE - CALL DLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) - END IF -* - AKK = A( RK, K ) - A( RK, K ) = ONE -* -* Compute Kth column of F: -* -* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**T*A(RK:M,K). -* - IF( K.LT.N ) THEN - CALL DGEMV( 'TRANSPOSE', M-RK+1, N-K, TAU( K ), - $ A( RK, K+1 ), LDA, A( RK, K ), 1, ZERO, - $ F( K+1, K ), 1 ) - END IF -* -* Padding F(1:K,K) with zeros. -* - DO 20 J = 1, K - F( J, K ) = ZERO - 20 CONTINUE -* -* Incremental updating of F: -* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**T -* *A(RK:M,K). -* - IF( K.GT.1 ) THEN - CALL DGEMV( 'TRANSPOSE', M-RK+1, K-1, -TAU( K ), A( RK, 1 ), - $ LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 ) -* - CALL DGEMV( 'NO TRANSPOSE', N, K-1, ONE, F( 1, 1 ), LDF, - $ AUXV( 1 ), 1, ONE, F( 1, K ), 1 ) - END IF -* -* Update the current row of A: -* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**T. -* - IF( K.LT.N ) THEN - CALL DGEMV( 'NO TRANSPOSE', N-K, K, -ONE, F( K+1, 1 ), LDF, - $ A( RK, 1 ), LDA, ONE, A( RK, K+1 ), LDA ) - END IF -* -* Update partial column norms. -* - IF( RK.LT.LASTRK ) THEN - DO 30 J = K + 1, N - IF( VN1( J ).NE.ZERO ) THEN -* -* NOTE: The following 4 lines follow from the analysis -* in -* Lapack Working Note 176. -* - TEMP = ABS( A( RK, J ) ) / VN1( J ) - TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) - TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 - IF( TEMP2 .LE. TOL3Z ) THEN - VN2( J ) = DBLE( LSTICC ) - LSTICC = J - ELSE - VN1( J ) = VN1( J )*SQRT( TEMP ) - END IF - END IF - 30 CONTINUE - END IF -* - A( RK, K ) = AKK -* -* End of while loop. -* - GO TO 10 - END IF - KB = K - RK = OFFSET + KB -* -* Apply the block reflector to the rest of the matrix: -* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - -* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**T. -* - IF( KB.LT.MIN( N, M-OFFSET ) ) THEN - CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M-RK, N-KB, KB, -ONE, - $ A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, - $ A( RK+1, KB+1 ), LDA ) - END IF -* -* Recomputation of difficult columns. -* - 40 CONTINUE - IF( LSTICC.GT.0 ) THEN - ITEMP = NINT( VN2( LSTICC ) ) - VN1( LSTICC ) = DNRM2( M-RK, A( RK+1, LSTICC ), 1 ) -* -* NOTE: The computation of VN1( LSTICC ) relies on the fact that -* SNRM2 does not fail on vectors with norm below the value of -* SQRT(DLAMCH('S')) -* - VN2( LSTICC ) = VN1( LSTICC ) - LSTICC = ITEMP - GO TO 40 - END IF -* - RETURN -* -* End of DLAQPS -* - END - SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER SIDE - INTEGER INCV, LDC, M, N - DOUBLE PRECISION TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLARF applies a real elementary reflector H to a real m by n matrix -* C, from either the left or the right. H is represented in the form -* -* H = I - tau * v * v**T -* -* where tau is a real scalar and v is a real vector. -* -* If tau = 0, then H is taken to be the unit matrix. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': form H * C -* = 'R': form C * H -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* V (input) DOUBLE PRECISION array, dimension -* (1 + (M-1)*abs(INCV)) if SIDE = 'L' -* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' -* The vector v in the representation of H. V is not used if -* TAU = 0. -* -* INCV (input) INTEGER -* The increment between elements of v. INCV <> 0. -* -* TAU (input) DOUBLE PRECISION -* The value tau in the representation of H. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by the matrix H * C if SIDE = 'L', -* or C * H if SIDE = 'R'. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* (N) if SIDE = 'L' -* or (M) if SIDE = 'R' -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL APPLYLEFT - INTEGER I, LASTV, LASTC -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DGER -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILADLR, ILADLC - EXTERNAL LSAME, ILADLR, ILADLC -* .. -* .. Executable Statements .. -* - APPLYLEFT = LSAME( SIDE, 'L' ) - LASTV = 0 - LASTC = 0 - IF( TAU.NE.ZERO ) THEN -! Set up variables for scanning V. LASTV begins pointing to the end -! of V. - IF( APPLYLEFT ) THEN - LASTV = M - ELSE - LASTV = N - END IF - IF( INCV.GT.0 ) THEN - I = 1 + (LASTV-1) * INCV - ELSE - I = 1 - END IF -! Look for the last non-zero row in V. - DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) - LASTV = LASTV - 1 - I = I - INCV - END DO - IF( APPLYLEFT ) THEN -! Scan for the last non-zero column in C(1:lastv,:). - LASTC = ILADLC(LASTV, N, C, LDC) - ELSE -! Scan for the last non-zero row in C(:,1:lastv). - LASTC = ILADLR(M, LASTV, C, LDC) - END IF - END IF -! Note that lastc.eq.0 renders the BLAS operations null; no special -! case is needed at this level. - IF( APPLYLEFT ) THEN -* -* Form H * C -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) -* - CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, - $ ZERO, WORK, 1 ) -* -* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * -* w(1:lastc,1)**T -* - CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) - END IF - ELSE -* -* Form C * H -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) -* - CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, - $ V, INCV, ZERO, WORK, 1 ) -* -* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * -* v(1:lastv,1)**T -* - CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) - END IF - END IF - RETURN -* -* End of DLARF -* - END - SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, - $ T, LDT, C, LDC, WORK, LDWORK ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, SIDE, STOREV, TRANS - INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), - $ WORK( LDWORK, * ) -* .. -* -* Purpose -* ======= -* -* DLARFB applies a real block reflector H or its transpose H**T to a -* real m by n matrix C, from either the left or the right. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply H or H**T from the Left -* = 'R': apply H or H**T from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply H (No transpose) -* = 'T': apply H**T (Transpose) -* -* DIRECT (input) CHARACTER*1 -* Indicates how H is formed from a product of elementary -* reflectors -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Indicates how the vectors which define the elementary -* reflectors are stored: -* = 'C': Columnwise -* = 'R': Rowwise -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* K (input) INTEGER -* The order of the matrix T (= the number of elementary -* reflectors whose product defines the block reflector). -* -* V (input) DOUBLE PRECISION array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,M) if STOREV = 'R' and SIDE = 'L' -* (LDV,N) if STOREV = 'R' and SIDE = 'R' -* The matrix V. See Further Details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); -* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); -* if STOREV = 'R', LDV >= K. -* -* T (input) DOUBLE PRECISION array, dimension (LDT,K) -* The triangular k by k matrix T in the representation of the -* block reflector. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) -* -* LDWORK (input) INTEGER -* The leading dimension of the array WORK. -* If SIDE = 'L', LDWORK >= max(1,N); -* if SIDE = 'R', LDWORK >= max(1,M). -* -* Further Details -* =============== -* -* The shape of the matrix V and the storage of the vectors which define -* the H(i) is best illustrated by the following example with n = 5 and -* k = 3. The elements equal to 1 are not stored; the corresponding -* array elements are modified but restored on exit. The rest of the -* array is not used. -* -* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -* -* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -* ( v1 1 ) ( 1 v2 v2 v2 ) -* ( v1 v2 1 ) ( 1 v3 v3 ) -* ( v1 v2 v3 ) -* ( v1 v2 v3 ) -* -* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -* -* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -* ( v1 v2 v3 ) ( v2 v2 v2 1 ) -* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -* ( 1 v3 ) -* ( 1 ) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - CHARACTER TRANST - INTEGER I, J, LASTV, LASTC -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILADLR, ILADLC - EXTERNAL LSAME, ILADLR, ILADLC -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DTRMM -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( LSAME( TRANS, 'N' ) ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* - IF( LSAME( STOREV, 'C' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 ) (first K rows) -* ( V2 ) -* where V1 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in -* WORK) -* -* W := C1**T -* - DO 10 J = 1, K - CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 10 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2**T *V2 -* - CALL DGEMM( 'Transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**T -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - V2 * W**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**T -* - DO 30 J = 1, K - DO 20 I = 1, LASTC - C( J, I ) = C( J, I ) - WORK( I, J ) - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C1 -* - DO 40 J = 1, K - CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) - 40 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2 * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**T -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - W * V2**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 60 J = 1, K - DO 50 I = 1, LASTC - C( I, J ) = C( I, J ) - WORK( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - ELSE -* -* Let V = ( V1 ) -* ( V2 ) (last K rows) -* where V2 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in -* WORK) -* -* W := C2**T -* - DO 70 J = 1, K - CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - 70 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1**T*V1 -* - CALL DGEMM( 'Transpose', 'No transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**T -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - V1 * W**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) - END IF -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) -* -* C2 := C2 - W**T -* - DO 90 J = 1, K - DO 80 I = 1, LASTC - C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C2 -* - DO 100 J = 1, K - CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 100 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1 * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**T -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - W * V1**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) - END IF -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) -* -* C2 := C2 - W -* - DO 120 J = 1, K - DO 110 I = 1, LASTC - C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) - 110 CONTINUE - 120 CONTINUE - END IF - END IF -* - ELSE IF( LSAME( STOREV, 'R' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 V2 ) (V1: first K columns) -* where V1 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) -* (stored in WORK) -* -* W := C1**T -* - DO 130 J = 1, K - CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 130 CONTINUE -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2**T*V2**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**T * W**T -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - V2**T * W**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, - $ ONE, C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**T -* - DO 150 J = 1, K - DO 140 I = 1, LASTC - C( J, I ) = C( J, I ) - WORK( I, J ) - 140 CONTINUE - 150 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) -* -* W := C1 -* - DO 160 J = 1, K - CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) - 160 CONTINUE -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2 * V2**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - W * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 180 J = 1, K - DO 170 I = 1, LASTC - C( I, J ) = C( I, J ) - WORK( I, J ) - 170 CONTINUE - 180 CONTINUE -* - END IF -* - ELSE -* -* Let V = ( V1 V2 ) (V2: last K columns) -* where V2 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) -* (stored in WORK) -* -* W := C2**T -* - DO 190 J = 1, K - CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - 190 CONTINUE -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1**T * V1**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**T * W**T -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - V1**T * W**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) -* -* C2 := C2 - W**T -* - DO 210 J = 1, K - DO 200 I = 1, LASTC - C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) - 200 CONTINUE - 210 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) -* -* W := C2 -* - DO 220 J = 1, K - CALL DCOPY( LASTC, C( 1, LASTV-K+J ), 1, - $ WORK( 1, J ), 1 ) - 220 CONTINUE -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1 * V1**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - W * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 240 J = 1, K - DO 230 I = 1, LASTC - C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) - 230 CONTINUE - 240 CONTINUE -* - END IF -* - END IF - END IF -* - RETURN -* -* End of DLARFB -* - END - SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION ALPHA, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* Purpose -* ======= -* -* DLARFG generates a real elementary reflector H of order n, such -* that -* -* H * ( alpha ) = ( beta ), H**T * H = I. -* ( x ) ( 0 ) -* -* where alpha and beta are scalars, and x is an (n-1)-element real -* vector. H is represented in the form -* -* H = I - tau * ( 1 ) * ( 1 v**T ) , -* ( v ) -* -* where tau is a real scalar and v is a real (n-1)-element -* vector. -* -* If the elements of x are all zero, then tau = 0 and H is taken to be -* the unit matrix. -* -* Otherwise 1 <= tau <= 2. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the elementary reflector. -* -* ALPHA (input/output) DOUBLE PRECISION -* On entry, the value alpha. -* On exit, it is overwritten with the value beta. -* -* X (input/output) DOUBLE PRECISION array, dimension -* (1+(N-2)*abs(INCX)) -* On entry, the vector x. -* On exit, it is overwritten with the vector v. -* -* INCX (input) INTEGER -* The increment between elements of X. INCX > 0. -* -* TAU (output) DOUBLE PRECISION -* The value tau. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, KNT - DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 - EXTERNAL DLAMCH, DLAPY2, DNRM2 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN -* .. -* .. External Subroutines .. - EXTERNAL DSCAL -* .. -* .. Executable Statements .. -* - IF( N.LE.1 ) THEN - TAU = ZERO - RETURN - END IF -* - XNORM = DNRM2( N-1, X, INCX ) -* - IF( XNORM.EQ.ZERO ) THEN -* -* H = I -* - TAU = ZERO - ELSE -* -* general case -* - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) - KNT = 0 - IF( ABS( BETA ).LT.SAFMIN ) THEN -* -* XNORM, BETA may be inaccurate; scale X and recompute them -* - RSAFMN = ONE / SAFMIN - 10 CONTINUE - KNT = KNT + 1 - CALL DSCAL( N-1, RSAFMN, X, INCX ) - BETA = BETA*RSAFMN - ALPHA = ALPHA*RSAFMN - IF( ABS( BETA ).LT.SAFMIN ) - $ GO TO 10 -* -* New BETA is at most 1, at least SAFMIN -* - XNORM = DNRM2( N-1, X, INCX ) - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - END IF - TAU = ( BETA-ALPHA ) / BETA - CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) -* -* If ALPHA is subnormal, it may lose relative accuracy -* - DO 20 J = 1, KNT - BETA = BETA*SAFMIN - 20 CONTINUE - ALPHA = BETA - END IF -* - RETURN -* -* End of DLARFG -* - END - SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* Purpose -* ======= -* -* DLARFT forms the triangular factor T of a real block reflector H -* of order n, which is defined as a product of k elementary reflectors. -* -* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; -* -* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. -* -* If STOREV = 'C', the vector which defines the elementary reflector -* H(i) is stored in the i-th column of the array V, and -* -* H = I - V * T * V**T -* -* If STOREV = 'R', the vector which defines the elementary reflector -* H(i) is stored in the i-th row of the array V, and -* -* H = I - V**T * T * V -* -* Arguments -* ========= -* -* DIRECT (input) CHARACTER*1 -* Specifies the order in which the elementary reflectors are -* multiplied to form the block reflector: -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Specifies how the vectors which define the elementary -* reflectors are stored (see also Further Details): -* = 'C': columnwise -* = 'R': rowwise -* -* N (input) INTEGER -* The order of the block reflector H. N >= 0. -* -* K (input) INTEGER -* The order of the triangular factor T (= the number of -* elementary reflectors). K >= 1. -* -* V (input/output) DOUBLE PRECISION array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,N) if STOREV = 'R' -* The matrix V. See further details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i). -* -* T (output) DOUBLE PRECISION array, dimension (LDT,K) -* The k by k triangular factor T of the block reflector. -* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is -* lower triangular. The rest of the array is not used. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* Further Details -* =============== -* -* The shape of the matrix V and the storage of the vectors which define -* the H(i) is best illustrated by the following example with n = 5 and -* k = 3. The elements equal to 1 are not stored; the corresponding -* array elements are modified but restored on exit. The rest of the -* array is not used. -* -* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -* -* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -* ( v1 1 ) ( 1 v2 v2 v2 ) -* ( v1 v2 1 ) ( 1 v3 v3 ) -* ( v1 v2 v3 ) -* ( v1 v2 v3 ) -* -* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -* -* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -* ( v1 v2 v3 ) ( v2 v2 v2 1 ) -* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -* ( 1 v3 ) -* ( 1 ) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, PREVLASTV, LASTV - DOUBLE PRECISION VII -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DTRMV -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - PREVLASTV = N - DO 20 I = 1, K - PREVLASTV = MAX( I, PREVLASTV ) - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 10 J = 1, I - T( J, I ) = ZERO - 10 CONTINUE - ELSE -* -* general case -* - VII = V( I, I ) - V( I, I ) = ONE - IF( LSAME( STOREV, 'C' ) ) THEN -! Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) -* - CALL DGEMV( 'Transpose', J-I+1, I-1, -TAU( I ), - $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, - $ T( 1, I ), 1 ) - ELSE -! Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T -* - CALL DGEMV( 'No transpose', I-1, J-I+1, -TAU( I ), - $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, - $ T( 1, I ), 1 ) - END IF - V( I, I ) = VII -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MAX( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - 20 CONTINUE - ELSE - PREVLASTV = 1 - DO 40 I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 30 J = I, K - T( J, I ) = ZERO - 30 CONTINUE - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN - VII = V( N-K+I, I ) - V( N-K+I, I ) = ONE -! Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) := -* - tau(i) * V(j:n-k+i,i+1:k)**T * -* V(j:n-k+i,i) -* - CALL DGEMV( 'Transpose', N-K+I-J+1, K-I, -TAU( I ), - $ V( J, I+1 ), LDV, V( J, I ), 1, ZERO, - $ T( I+1, I ), 1 ) - V( N-K+I, I ) = VII - ELSE - VII = V( I, N-K+I ) - V( I, N-K+I ) = ONE -! Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) := -* - tau(i) * V(i+1:k,j:n-k+i) * -* V(i,j:n-k+i)**T -* - CALL DGEMV( 'No transpose', K-I, N-K+I-J+1, - $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, - $ ZERO, T( I+1, I ), 1 ) - V( I, N-K+I ) = VII - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - T( I, I ) = TAU( I ) - END IF - 40 CONTINUE - END IF - RETURN -* -* End of DLARFT -* - END - SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASWP performs a series of row interchanges on the matrix A. -* One row interchange is initiated for each of rows K1 through K2 of A. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the matrix of column dimension N to which the row -* interchanges will be applied. -* On exit, the permuted matrix. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* -* K1 (input) INTEGER -* The first element of IPIV for which a row interchange will -* be done. -* -* K2 (input) INTEGER -* The last element of IPIV for which a row interchange will -* be done. -* -* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) -* The vector of pivot indices. Only the elements in positions -* K1 through K2 of IPIV are accessed. -* IPIV(K) = L implies rows K and L are to be interchanged. -* -* INCX (input) INTEGER -* The increment between successive values of IPIV. If IPIV -* is negative, the pivots are applied in reverse order. -* -* Further Details -* =============== -* -* Modified by -* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - DOUBLE PRECISION TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) for each of rows K1 through K2. -* - IF( INCX.GT.0 ) THEN - IX0 = K1 - I1 = K1 - I2 = K2 - INC = 1 - ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX - I1 = K2 - I2 = K1 - INC = -1 - ELSE - RETURN - END IF -* - N32 = ( N / 32 )*32 - IF( N32.NE.0 ) THEN - DO 30 J = 1, N32, 32 - IX = IX0 - DO 20 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 10 K = J, J + 31 - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 10 CONTINUE - END IF - IX = IX + INCX - 20 CONTINUE - 30 CONTINUE - END IF - IF( N32.NE.N ) THEN - N32 = N32 + 1 - IX = IX0 - DO 50 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 40 K = N32, N - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 40 CONTINUE - END IF - IX = IX + INCX - 50 CONTINUE - END IF -* - RETURN -* -* End of DLASWP -* - END - SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORM2R overwrites the general real m by n matrix C with -* -* Q * C if SIDE = 'L' and TRANS = 'N', or -* -* Q**T* C if SIDE = 'L' and TRANS = 'T', or -* -* C * Q if SIDE = 'R' and TRANS = 'N', or -* -* C * Q**T if SIDE = 'R' and TRANS = 'T', -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**T from the Left -* = 'R': apply Q or Q**T from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply Q (No transpose) -* = 'T': apply Q**T (Transpose) -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGEQRF in the first k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* (N) if SIDE = 'L', -* (M) if SIDE = 'R' -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORM2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) - $ THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), - $ LDC, WORK ) - A( I, I ) = AII - 10 CONTINUE - RETURN -* -* End of DORM2R -* - END - SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORMQR overwrites the general real M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'T': Q**T * C C * Q**T -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**T from the Left; -* = 'R': apply Q or Q**T from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'T': Transpose, apply Q**T. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGEQRF in the first k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension -* (MAX(1,LWORK)) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW -* .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = MAX( 1, NW )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - ELSE - IWS = NW - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), T, LDT ) - IF( LEFT ) THEN -* -* H or H**T is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H**T is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H**T -* - CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, - $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, - $ WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMQR -* - END - DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) -* -* -- LAPACK auxiliary routine (version 3.3.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* Based on LAPACK DLAMCH but with Fortran 95 query functions -* See: http://www.cs.utk.edu/~luszczek/lapack/lamch.html -* and -* http://www.netlib.org/lapack-dev/lapack-coding/program-style.html#id2537289 -* July 2010 -* -* .. Scalar Arguments .. - CHARACTER CMACH -* .. -* -* Purpose -* ======= -* -* DLAMCH determines double precision machine parameters. -* -* Arguments -* ========= -* -* CMACH (input) CHARACTER*1 -* Specifies the value to be returned by DLAMCH: -* = 'E' or 'e', DLAMCH := eps -* = 'S' or 's , DLAMCH := sfmin -* = 'B' or 'b', DLAMCH := base -* = 'P' or 'p', DLAMCH := eps*base -* = 'N' or 'n', DLAMCH := t -* = 'R' or 'r', DLAMCH := rnd -* = 'M' or 'm', DLAMCH := emin -* = 'U' or 'u', DLAMCH := rmin -* = 'L' or 'l', DLAMCH := emax -* = 'O' or 'o', DLAMCH := rmax -* -* where -* -* eps = relative machine precision -* sfmin = safe minimum, such that 1/sfmin does not overflow -* base = base of the machine -* prec = eps*base -* t = number of (base) digits in the mantissa -* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise -* emin = minimum exponent before (gradual) underflow -* rmin = underflow threshold - base**(emin-1) -* emax = largest exponent before overflow -* rmax = overflow threshold - (base**emax)*(1-eps) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, - $ MINEXPONENT, RADIX, TINY -* .. -* .. Executable Statements .. -* -* -* Assume rounding, not chopping. Always. -* - RND = ONE -* - IF( ONE.EQ.RND ) THEN - EPS = EPSILON(ZERO) * 0.5 - ELSE - EPS = EPSILON(ZERO) - END IF -* - IF( LSAME( CMACH, 'E' ) ) THEN - RMACH = EPS - ELSE IF( LSAME( CMACH, 'S' ) ) THEN - SFMIN = TINY(ZERO) - SMALL = ONE / HUGE(ZERO) - IF( SMALL.GE.SFMIN ) THEN -* -* Use SMALL plus a bit, to avoid the possibility of rounding -* causing overflow when computing 1/sfmin. -* - SFMIN = SMALL*( ONE+EPS ) - END IF - RMACH = SFMIN - ELSE IF( LSAME( CMACH, 'B' ) ) THEN - RMACH = RADIX(ZERO) - ELSE IF( LSAME( CMACH, 'P' ) ) THEN - RMACH = EPS * RADIX(ZERO) - ELSE IF( LSAME( CMACH, 'N' ) ) THEN - RMACH = DIGITS(ZERO) - ELSE IF( LSAME( CMACH, 'R' ) ) THEN - RMACH = RND - ELSE IF( LSAME( CMACH, 'M' ) ) THEN - RMACH = MINEXPONENT(ZERO) - ELSE IF( LSAME( CMACH, 'U' ) ) THEN - RMACH = tiny(zero) - ELSE IF( LSAME( CMACH, 'L' ) ) THEN - RMACH = MAXEXPONENT(ZERO) - ELSE IF( LSAME( CMACH, 'O' ) ) THEN - RMACH = HUGE(ZERO) - ELSE - RMACH = ZERO - END IF -* - DLAMCH = RMACH - RETURN -* -* End of DLAMCH -* - END -************************************************************************ -* - INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER ISPEC - REAL ONE, ZERO -* .. -* -* Purpose -* ======= -* -* IEEECK is called from the ILAENV to verify that Infinity and -* possibly NaN arithmetic is safe (i.e. will not trap). -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies whether to test just for inifinity arithmetic -* or whether to test for infinity and NaN arithmetic. -* = 0: Verify infinity arithmetic only. -* = 1: Verify infinity and NaN arithmetic. -* -* ZERO (input) REAL -* Must contain the value 0.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* ONE (input) REAL -* Must contain the value 1.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* RETURN VALUE: INTEGER -* = 0: Arithmetic failed to produce the correct answers -* = 1: Arithmetic produced the correct answers -* -* ===================================================================== -* -* .. Local Scalars .. - REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, - $ NEGZRO, NEWZRO, POSINF -* .. -* .. Executable Statements .. - IEEECK = 1 -* - POSINF = ONE / ZERO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = -ONE / ZERO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGZRO = ONE / ( NEGINF+ONE ) - IF( NEGZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = ONE / NEGZRO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEWZRO = NEGZRO + ZERO - IF( NEWZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = ONE / NEWZRO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = NEGINF*POSINF - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = POSINF*POSINF - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* -* -* -* -* Return if we were only asked to check infinity arithmetic -* - IF( ISPEC.EQ.0 ) - $ RETURN -* - NAN1 = POSINF + NEGINF -* - NAN2 = POSINF / NEGINF -* - NAN3 = POSINF / POSINF -* - NAN4 = POSINF*ZERO -* - NAN5 = NEGINF*NEGZRO -* - NAN6 = NAN5*ZERO -* - IF( NAN1.EQ.NAN1 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN2.EQ.NAN2 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN3.EQ.NAN3 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN4.EQ.NAN4 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN5.EQ.NAN5 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN6.EQ.NAN6 ) THEN - IEEECK = 0 - RETURN - END IF -* - RETURN - END - INTEGER FUNCTION ILADLC( M, N, A, LDA ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.2.2) -- -* -* -- June 2010 -- -* -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ILADLC scans A for its last non-zero column. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The m by n matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( N.EQ.0 ) THEN - ILADLC = N - ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILADLC = N - ELSE -* Now scan each column from the end, returning with the first -* non-zero. - DO ILADLC = N, 1, -1 - DO I = 1, M - IF( A(I, ILADLC).NE.ZERO ) RETURN - END DO - END DO - END IF - RETURN - END - INTEGER FUNCTION ILADLR( M, N, A, LDA ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ILADLR scans A for its last non-zero row. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The m by n matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( M.EQ.0 ) THEN - ILADLR = M - ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILADLR = M - ELSE -* Scan up each column tracking the last zero row seen. - ILADLR = 0 - DO J = 1, N - I=M - DO WHILE ((A(I,J).NE.ZERO).AND.(I.GE.1)) - I=I-1 - ENDDO - ILADLR = MAX( ILADLR, I ) - END DO - END IF - RETURN - END - INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) -* -* -- LAPACK auxiliary routine (version 3.2.1) -- -* -* -- April 2009 -- -* -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER*( * ) NAME, OPTS - INTEGER ISPEC, N1, N2, N3, N4 -* .. -* -* Purpose -* ======= -* -* ILAENV is called from the LAPACK routines to choose problem-dependent -* parameters for the local environment. See ISPEC for a description of -* the parameters. -* -* ILAENV returns an INTEGER -* if ILAENV >= 0: ILAENV returns the value of the parameter specified -* by ISPEC -* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal -* value. -* -* This version provides a set of parameters which should give good, -* but not optimal, performance on many of the currently available -* computers. Users are encouraged to modify this subroutine to set -* the tuning parameters for their particular machine using the option -* and problem size information in the arguments. -* -* This routine will not function correctly if it is converted to all -* lower case. Converting it to all upper case is allowed. -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies the parameter to be returned as the value of -* ILAENV. -* = 1: the optimal blocksize; if this value is 1, an unblocked -* algorithm will give the best performance. -* = 2: the minimum block size for which the block routine -* should be used; if the usable block size is less than -* this value, an unblocked routine should be used. -* = 3: the crossover point (in a block routine, for N less -* than this value, an unblocked routine should be used) -* = 4: the number of shifts, used in the nonsymmetric -* eigenvalue routines (DEPRECATED) -* = 5: the minimum column dimension for blocking to be used; -* rectangular blocks must have dimension at least k by m, -* where k is given by ILAENV(2,...) and m by ILAENV(5,...) -* = 6: the crossover point for the SVD (when reducing an m by n -* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds -* this value, a QR factorization is used first to reduce -* the matrix to a triangular form.) -* = 7: the number of processors -* = 8: the crossover point for the multishift QR method -* for nonsymmetric eigenvalue problems (DEPRECATED) -* = 9: maximum size of the subproblems at the bottom of the -* computation tree in the divide-and-conquer algorithm -* (used by xGELSD and xGESDD) -* =10: ieee NaN arithmetic can be trusted not to trap -* =11: infinity arithmetic can be trusted not to trap -* 12 <= ISPEC <= 16: -* xHSEQR or one of its subroutines, -* see IPARMQ for detailed explanation -* -* NAME (input) CHARACTER*(*) -* The name of the calling subroutine, in either upper case or -* lower case. -* -* OPTS (input) CHARACTER*(*) -* The character options to the subroutine NAME, concatenated -* into a single character string. For example, UPLO = 'U', -* TRANS = 'T', and DIAG = 'N' for a triangular routine would -* be specified as OPTS = 'UTN'. -* -* N1 (input) INTEGER -* N2 (input) INTEGER -* N3 (input) INTEGER -* N4 (input) INTEGER -* Problem dimensions for the subroutine NAME; these may not all -* be required. -* -* Further Details -* =============== -* -* The following conventions have been used when calling ILAENV from the -* LAPACK routines: -* 1) OPTS is a concatenation of all of the character options to -* subroutine NAME, in the same order that they appear in the -* argument list for NAME, even if they are not used in determining -* the value of the parameter specified by ISPEC. -* 2) The problem dimensions N1, N2, N3, N4 are specified in the order -* that they appear in the argument list for NAME. N1 is used -* first, N2 second, and so on, and unused problem dimensions are -* passed a value of -1. -* 3) The parameter value returned by ILAENV is checked for validity in -* the calling subroutine. For example, ILAENV is used to retrieve -* the optimal blocksize for STRTRI as follows: -* -* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) -* IF( NB.LE.1 ) NB = MAX( 1, N ) -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IC, IZ, NB, NBMIN, NX - LOGICAL CNAME, SNAME - CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 -* .. -* .. Intrinsic Functions .. - INTRINSIC CHAR, ICHAR, INT, MIN, REAL -* .. -* .. External Functions .. - INTEGER IEEECK, IPARMQ - EXTERNAL IEEECK, IPARMQ -* .. -* .. Executable Statements .. -* - GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, - $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC -* -* Invalid value for ISPEC -* - ILAENV = -1 - RETURN -* - 10 CONTINUE -* -* Convert NAME to upper case if the first character is lower case. -* - ILAENV = 1 - SUBNAM = NAME - IC = ICHAR( SUBNAM( 1: 1 ) ) - IZ = ICHAR( 'Z' ) - IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN -* -* ASCII character set -* - IF( IC.GE.97 .AND. IC.LE.122 ) THEN - SUBNAM( 1: 1 ) = CHAR( IC-32 ) - DO 20 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( IC.GE.97 .AND. IC.LE.122 ) - $ SUBNAM( I: I ) = CHAR( IC-32 ) - 20 CONTINUE - END IF -* - ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN -* -* EBCDIC character set -* - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN - SUBNAM( 1: 1 ) = CHAR( IC+64 ) - DO 30 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: - $ I ) = CHAR( IC+64 ) - 30 CONTINUE - END IF -* - ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN -* -* Prime machines: ASCII+128 -* - IF( IC.GE.225 .AND. IC.LE.250 ) THEN - SUBNAM( 1: 1 ) = CHAR( IC-32 ) - DO 40 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( IC.GE.225 .AND. IC.LE.250 ) - $ SUBNAM( I: I ) = CHAR( IC-32 ) - 40 CONTINUE - END IF - END IF -* - C1 = SUBNAM( 1: 1 ) - SNAME = C1.EQ.'S' .OR. C1.EQ.'D' - CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' - IF( .NOT.( CNAME .OR. SNAME ) ) - $ RETURN - C2 = SUBNAM( 2: 3 ) - C3 = SUBNAM( 4: 6 ) - C4 = C3( 2: 3 ) -* - GO TO ( 50, 60, 70 )ISPEC -* - 50 CONTINUE -* -* ISPEC = 1: block size -* -* In these examples, separate code is provided for setting NB for -* real and complex. We assume that NB will take the same value in -* single or double precision. -* - NB = 1 -* - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'PO' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRF' ) THEN - NB = 64 - ELSE IF( C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - END IF - ELSE IF( C2.EQ.'GB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'PB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'TR' ) THEN - IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'LA' ) THEN - IF( C3.EQ.'UUM' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN - IF( C3.EQ.'EBZ' ) THEN - NB = 1 - END IF - END IF - ILAENV = NB - RETURN -* - 60 CONTINUE -* -* ISPEC = 2: minimum block size -* - NBMIN = 2 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. - $ 'QLF' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NBMIN = 8 - ELSE - NBMIN = 8 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - END IF - END IF - ILAENV = NBMIN - RETURN -* - 70 CONTINUE -* -* ISPEC = 3: crossover point -* - NX = 0 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. - $ 'QLF' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NX = 128 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NX = 128 - END IF - END IF - END IF - ILAENV = NX - RETURN -* - 80 CONTINUE -* -* ISPEC = 4: number of shifts (used by xHSEQR) -* - ILAENV = 6 - RETURN -* - 90 CONTINUE -* -* ISPEC = 5: minimum column dimension (not used) -* - ILAENV = 2 - RETURN -* - 100 CONTINUE -* -* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) -* - ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) - RETURN -* - 110 CONTINUE -* -* ISPEC = 7: number of processors (not used) -* - ILAENV = 1 - RETURN -* - 120 CONTINUE -* -* ISPEC = 8: crossover point for multishift (used by xHSEQR) -* - ILAENV = 50 - RETURN -* - 130 CONTINUE -* -* ISPEC = 9: maximum size of the subproblems at the bottom of the -* computation tree in the divide-and-conquer algorithm -* (used by xGELSD and xGESDD) -* - ILAENV = 25 - RETURN -* - 140 CONTINUE -* -* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap -* -* ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 1, 0.0, 1.0 ) - END IF - RETURN -* - 150 CONTINUE -* -* ISPEC = 11: infinity arithmetic can be trusted not to trap -* -* ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 0, 0.0, 1.0 ) - END IF - RETURN -* - 160 CONTINUE -* -* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. -* - ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) - RETURN -* -* End of ILAENV -* - END - INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - INTEGER IHI, ILO, ISPEC, LWORK, N - CHARACTER NAME*( * ), OPTS*( * ) -* -* Purpose -* ======= -* -* This program sets problem and machine dependent parameters -* useful for xHSEQR and its subroutines. It is called whenever -* ILAENV is called with 12 <= ISPEC <= 16 -* -* Arguments -* ========= -* -* ISPEC (input) integer scalar -* ISPEC specifies which tunable parameter IPARMQ should -* return. -* -* ISPEC=12: (INMIN) Matrices of order nmin or less -* are sent directly to xLAHQR, the implicit -* double shift QR algorithm. NMIN must be -* at least 11. -* -* ISPEC=13: (INWIN) Size of the deflation window. -* This is best set greater than or equal to -* the number of simultaneous shifts NS. -* Larger matrices benefit from larger deflation -* windows. -* -* ISPEC=14: (INIBL) Determines when to stop nibbling and -* invest in an (expensive) multi-shift QR sweep. -* If the aggressive early deflation subroutine -* finds LD converged eigenvalues from an order -* NW deflation window and LD.GT.(NW*NIBBLE)/100, -* then the next QR sweep is skipped and early -* deflation is applied immediately to the -* remaining active diagonal block. Setting -* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a -* multi-shift QR sweep whenever early deflation -* finds a converged eigenvalue. Setting -* IPARMQ(ISPEC=14) greater than or equal to 100 -* prevents TTQRE from skipping a multi-shift -* QR sweep. -* -* ISPEC=15: (NSHFTS) The number of simultaneous shifts in -* a multi-shift QR iteration. -* -* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the -* following meanings. -* 0: During the multi-shift QR sweep, -* xLAQR5 does not accumulate reflections and -* does not use matrix-matrix multiply to -* update the far-from-diagonal matrix -* entries. -* 1: During the multi-shift QR sweep, -* xLAQR5 and/or xLAQRaccumulates reflections -* and uses -* matrix-matrix multiply to update the -* far-from-diagonal matrix entries. -* 2: During the multi-shift QR sweep. -* xLAQR5 accumulates reflections and takes -* advantage of 2-by-2 block structure during -* matrix-matrix multiplies. -* (If xTRMM is slower than xGEMM, then -* IPARMQ(ISPEC=16)=1 may be more efficient than -* IPARMQ(ISPEC=16)=2 despite the greater level of -* arithmetic work implied by the latter choice.) -* -* NAME (input) character string -* Name of the calling subroutine -* -* OPTS (input) character string -* This is a concatenation of the string arguments to -* TTQRE. -* -* N (input) integer scalar -* N is the order of the Hessenberg matrix H. -* -* ILO (input) INTEGER -* IHI (input) INTEGER -* It is assumed that H is already upper triangular -* in rows and columns 1:ILO-1 and IHI+1:N. -* -* LWORK (input) integer scalar -* The amount of workspace available. -* -* Further Details -* =============== -* -* Little is known about how best to choose these parameters. -* It is possible to use different values of the parameters -* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. -* -* It is probably best to choose different parameters for -* different matrices and different parameters at different -* times during the iteration, but this has not been -* implemented --- yet. -* -* -* The best choices of most of the parameters depend -* in an ill-understood way on the relative execution -* rate of xLAQR3 and xLAQR5 and on the nature of each -* particular eigenvalue problem. Experiment may be the -* only practical way to determine which choices are most -* effective. -* -* Following is a list of default values supplied by IPARMQ. -* These defaults may be adjusted in order to attain better -* performance in any particular computational environment. -* -* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. -* Default: 75. (Must be at least 11.) -* -* IPARMQ(ISPEC=13) Recommended deflation window size. -* This depends on ILO, IHI and NS, the -* number of simultaneous shifts returned -* by IPARMQ(ISPEC=15). The default for -* (IHI-ILO+1).LE.500 is NS. The default -* for (IHI-ILO+1).GT.500 is 3*NS/2. -* -* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. -* -* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. -* a multi-shift QR iteration. -* -* If IHI-ILO+1 is ... -* -* greater than ...but less ... the -* or equal to ... than default is -* -* 0 30 NS = 2+ -* 30 60 NS = 4+ -* 60 150 NS = 10 -* 150 590 NS = ** -* 590 3000 NS = 64 -* 3000 6000 NS = 128 -* 6000 infinity NS = 256 -* -* (+) By default matrices of this order are -* passed to the implicit double shift routine -* xLAHQR. See IPARMQ(ISPEC=12) above. These -* values of NS are used only in case of a rare -* xLAHQR failure. -* -* (**) The asterisks (**) indicate an ad-hoc -* function increasing from 10 to 64. -* -* IPARMQ(ISPEC=16) Select structured matrix multiply. -* (See ISPEC=16 above for details.) -* Default: 3. -* -* ================================================================ -* .. Parameters .. - INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 - PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, - $ ISHFTS = 15, IACC22 = 16 ) - INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP - PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, - $ NIBBLE = 14, KNWSWP = 500 ) - REAL TWO - PARAMETER ( TWO = 2.0 ) -* .. -* .. Local Scalars .. - INTEGER NH, NS -* .. -* .. Intrinsic Functions .. - INTRINSIC LOG, MAX, MOD, NINT, REAL -* .. -* .. Executable Statements .. - IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. - $ ( ISPEC.EQ.IACC22 ) ) THEN -* -* ==== Set the number simultaneous shifts ==== -* - NH = IHI - ILO + 1 - NS = 2 - IF( NH.GE.30 ) - $ NS = 4 - IF( NH.GE.60 ) - $ NS = 10 - IF( NH.GE.150 ) - $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) - IF( NH.GE.590 ) - $ NS = 64 - IF( NH.GE.3000 ) - $ NS = 128 - IF( NH.GE.6000 ) - $ NS = 256 - NS = MAX( 2, NS-MOD( NS, 2 ) ) - END IF -* - IF( ISPEC.EQ.INMIN ) THEN -* -* -* ===== Matrices of order smaller than NMIN get sent -* . to xLAHQR, the classic double shift algorithm. -* . This must be at least 11. ==== -* - IPARMQ = NMIN -* - ELSE IF( ISPEC.EQ.INIBL ) THEN -* -* ==== INIBL: skip a multi-shift qr iteration and -* . whenever aggressive early deflation finds -* . at least (NIBBLE*(window size)/100) deflations. ==== -* - IPARMQ = NIBBLE -* - ELSE IF( ISPEC.EQ.ISHFTS ) THEN -* -* ==== NSHFTS: The number of simultaneous shifts ===== -* - IPARMQ = NS -* - ELSE IF( ISPEC.EQ.INWIN ) THEN -* -* ==== NW: deflation window size. ==== -* - IF( NH.LE.KNWSWP ) THEN - IPARMQ = NS - ELSE - IPARMQ = 3*NS / 2 - END IF -* - ELSE IF( ISPEC.EQ.IACC22 ) THEN -* -* ==== IACC22: Whether to accumulate reflections -* . before updating the far-from-diagonal elements -* . and whether to use 2-by-2 block structure while -* . doing it. A small amount of work could be saved -* . by making this choice dependent also upon the -* . NH=IHI-ILO+1. -* - IPARMQ = 0 - IF( NS.GE.KACMIN ) - $ IPARMQ = 1 - IF( NS.GE.K22MIN ) - $ IPARMQ = 2 -* - ELSE -* ===== invalid value of ispec ===== - IPARMQ = -1 -* - END IF -* -* ==== End of IPARMQ ==== -* - END - diff --git a/src/dependencies/slatec.f b/src/dependencies/slatec.f deleted file mode 100644 index c652a26..0000000 --- a/src/dependencies/slatec.f +++ /dev/null @@ -1,5023 +0,0 @@ -*DECK DLSEI - SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, - + RNORML, MODE, WS, IP) -C***BEGIN PROLOGUE DLSEI -C***PURPOSE Solve a linearly constrained least squares problem with -C equality and inequality constraints, and optionally compute -C a covariance matrix. -C***LIBRARY SLATEC -C***CATEGORY K1A2A, D9 -C***TYPE DOUBLE PRECISION (LSEI-S, DLSEI-D) -C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, -C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, -C QUADRATIC PROGRAMMING -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Abstract -C -C This subprogram solves a linearly constrained least squares -C problem with both equality and inequality constraints, and, if the -C user requests, obtains a covariance matrix of the solution -C parameters. -C -C Suppose there are given matrices E, A and G of respective -C dimensions ME by N, MA by N and MG by N, and vectors F, B and H of -C respective lengths ME, MA and MG. This subroutine solves the -C linearly constrained least squares problem -C -C EX = F, (E ME by N) (equations to be exactly -C satisfied) -C AX = B, (A MA by N) (equations to be -C approximately satisfied, -C least squares sense) -C GX .GE. H,(G MG by N) (inequality constraints) -C -C The inequalities GX .GE. H mean that every component of the -C product GX must be .GE. the corresponding component of H. -C -C In case the equality constraints cannot be satisfied, a -C generalized inverse solution residual vector length is obtained -C for F-EX. This is the minimal length possible for F-EX. -C -C Any values ME .GE. 0, MA .GE. 0, or MG .GE. 0 are permitted. The -C rank of the matrix E is estimated during the computation. We call -C this value KRANKE. It is an output parameter in IP(1) defined -C below. Using a generalized inverse solution of EX=F, a reduced -C least squares problem with inequality constraints is obtained. -C The tolerances used in these tests for determining the rank -C of E and the rank of the reduced least squares problem are -C given in Sandia Tech. Rept. SAND-78-1290. They can be -C modified by the user if new values are provided in -C the option list of the array PRGOPT(*). -C -C The user must dimension all arrays appearing in the call list.. -C W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2) -C where K=MAX(MA+MG,N). This allows for a solution of a range of -C problems in the given working space. The dimension of WS(*) -C given is a necessary overestimate. Once a particular problem -C has been run, the output parameter IP(3) gives the actual -C dimension required for that problem. -C -C The parameters for DLSEI( ) are -C -C Input.. All TYPE REAL variables are DOUBLE PRECISION -C -C W(*,*),MDW, The array W(*,*) is doubly subscripted with -C ME,MA,MG,N first dimensioning parameter equal to MDW. -C For this discussion let us call M = ME+MA+MG. Then -C MDW must satisfy MDW .GE. M. The condition -C MDW .LT. M is an error. -C -C The array W(*,*) contains the matrices and vectors -C -C (E F) -C (A B) -C (G H) -C -C in rows and columns 1,...,M and 1,...,N+1 -C respectively. -C -C The integers ME, MA, and MG are the -C respective matrix row dimensions -C of E, A and G. Each matrix has N columns. -C -C PRGOPT(*) This real-valued array is the option vector. -C If the user is satisfied with the nominal -C subprogram features set -C -C PRGOPT(1)=1 (or PRGOPT(1)=1.0) -C -C Otherwise PRGOPT(*) is a linked list consisting of -C groups of data of the following form -C -C LINK -C KEY -C DATA SET -C -C The parameters LINK and KEY are each one word. -C The DATA SET can be comprised of several words. -C The number of items depends on the value of KEY. -C The value of LINK points to the first -C entry of the next group of data within -C PRGOPT(*). The exception is when there are -C no more options to change. In that -C case, LINK=1 and the values KEY and DATA SET -C are not referenced. The general layout of -C PRGOPT(*) is as follows. -C -C ...PRGOPT(1) = LINK1 (link to first entry of next group) -C . PRGOPT(2) = KEY1 (key to the option change) -C . PRGOPT(3) = data value (data value for this change) -C . . -C . . -C . . -C ...PRGOPT(LINK1) = LINK2 (link to the first entry of -C . next group) -C . PRGOPT(LINK1+1) = KEY2 (key to the option change) -C . PRGOPT(LINK1+2) = data value -C ... . -C . . -C . . -C ...PRGOPT(LINK) = 1 (no more options to change) -C -C Values of LINK that are nonpositive are errors. -C A value of LINK .GT. NLINK=100000 is also an error. -C This helps prevent using invalid but positive -C values of LINK that will probably extend -C beyond the program limits of PRGOPT(*). -C Unrecognized values of KEY are ignored. The -C order of the options is arbitrary and any number -C of options can be changed with the following -C restriction. To prevent cycling in the -C processing of the option array, a count of the -C number of options changed is maintained. -C Whenever this count exceeds NOPT=1000, an error -C message is printed and the subprogram returns. -C -C Options.. -C -C KEY=1 -C Compute in W(*,*) the N by N -C covariance matrix of the solution variables -C as an output parameter. Nominally the -C covariance matrix will not be computed. -C (This requires no user input.) -C The data set for this option is a single value. -C It must be nonzero when the covariance matrix -C is desired. If it is zero, the covariance -C matrix is not computed. When the covariance matrix -C is computed, the first dimensioning parameter -C of the array W(*,*) must satisfy MDW .GE. MAX(M,N). -C -C KEY=10 -C Suppress scaling of the inverse of the -C normal matrix by the scale factor RNORM**2/ -C MAX(1, no. of degrees of freedom). This option -C only applies when the option for computing the -C covariance matrix (KEY=1) is used. With KEY=1 and -C KEY=10 used as options the unscaled inverse of the -C normal matrix is returned in W(*,*). -C The data set for this option is a single value. -C When it is nonzero no scaling is done. When it is -C zero scaling is done. The nominal case is to do -C scaling so if option (KEY=1) is used alone, the -C matrix will be scaled on output. -C -C KEY=2 -C Scale the nonzero columns of the -C entire data matrix. -C (E) -C (A) -C (G) -C -C to have length one. The data set for this -C option is a single value. It must be -C nonzero if unit length column scaling -C is desired. -C -C KEY=3 -C Scale columns of the entire data matrix -C (E) -C (A) -C (G) -C -C with a user-provided diagonal matrix. -C The data set for this option consists -C of the N diagonal scaling factors, one for -C each matrix column. -C -C KEY=4 -C Change the rank determination tolerance for -C the equality constraint equations from -C the nominal value of SQRT(DRELPR). This quantity can -C be no smaller than DRELPR, the arithmetic- -C storage precision. The quantity DRELPR is the -C largest positive number such that T=1.+DRELPR -C satisfies T .EQ. 1. The quantity used -C here is internally restricted to be at -C least DRELPR. The data set for this option -C is the new tolerance. -C -C KEY=5 -C Change the rank determination tolerance for -C the reduced least squares equations from -C the nominal value of SQRT(DRELPR). This quantity can -C be no smaller than DRELPR, the arithmetic- -C storage precision. The quantity used -C here is internally restricted to be at -C least DRELPR. The data set for this option -C is the new tolerance. -C -C For example, suppose we want to change -C the tolerance for the reduced least squares -C problem, compute the covariance matrix of -C the solution parameters, and provide -C column scaling for the data matrix. For -C these options the dimension of PRGOPT(*) -C must be at least N+9. The Fortran statements -C defining these options would be as follows: -C -C PRGOPT(1)=4 (link to entry 4 in PRGOPT(*)) -C PRGOPT(2)=1 (covariance matrix key) -C PRGOPT(3)=1 (covariance matrix wanted) -C -C PRGOPT(4)=7 (link to entry 7 in PRGOPT(*)) -C PRGOPT(5)=5 (least squares equas. tolerance key) -C PRGOPT(6)=... (new value of the tolerance) -C -C PRGOPT(7)=N+9 (link to entry N+9 in PRGOPT(*)) -C PRGOPT(8)=3 (user-provided column scaling key) -C -C CALL DCOPY (N, D, 1, PRGOPT(9), 1) (Copy the N -C scaling factors from the user array D(*) -C to PRGOPT(9)-PRGOPT(N+8)) -C -C PRGOPT(N+9)=1 (no more options to change) -C -C The contents of PRGOPT(*) are not modified -C by the subprogram. -C The options for WNNLS( ) can also be included -C in this array. The values of KEY recognized -C by WNNLS( ) are 6, 7 and 8. Their functions -C are documented in the usage instructions for -C subroutine WNNLS( ). Normally these options -C do not need to be modified when using DLSEI( ). -C -C IP(1), The amounts of working storage actually -C IP(2) allocated for the working arrays WS(*) and -C IP(*), respectively. These quantities are -C compared with the actual amounts of storage -C needed by DLSEI( ). Insufficient storage -C allocated for either WS(*) or IP(*) is an -C error. This feature was included in DLSEI( ) -C because miscalculating the storage formulas -C for WS(*) and IP(*) might very well lead to -C subtle and hard-to-find execution errors. -C -C The length of WS(*) must be at least -C -C LW = 2*(ME+N)+K+(MG+2)*(N+7) -C -C where K = max(MA+MG,N) -C This test will not be made if IP(1).LE.0. -C -C The length of IP(*) must be at least -C -C LIP = MG+2*N+2 -C This test will not be made if IP(2).LE.0. -C -C Output.. All TYPE REAL variables are DOUBLE PRECISION -C -C X(*),RNORME, The array X(*) contains the solution parameters -C RNORML if the integer output flag MODE = 0 or 1. -C The definition of MODE is given directly below. -C When MODE = 0 or 1, RNORME and RNORML -C respectively contain the residual vector -C Euclidean lengths of F - EX and B - AX. When -C MODE=1 the equality constraint equations EX=F -C are contradictory, so RNORME .NE. 0. The residual -C vector F-EX has minimal Euclidean length. For -C MODE .GE. 2, none of these parameters is defined. -C -C MODE Integer flag that indicates the subprogram -C status after completion. If MODE .GE. 2, no -C solution has been computed. -C -C MODE = -C -C 0 Both equality and inequality constraints -C are compatible and have been satisfied. -C -C 1 Equality constraints are contradictory. -C A generalized inverse solution of EX=F was used -C to minimize the residual vector length F-EX. -C In this sense, the solution is still meaningful. -C -C 2 Inequality constraints are contradictory. -C -C 3 Both equality and inequality constraints -C are contradictory. -C -C The following interpretation of -C MODE=1,2 or 3 must be made. The -C sets consisting of all solutions -C of the equality constraints EX=F -C and all vectors satisfying GX .GE. H -C have no points in common. (In -C particular this does not say that -C each individual set has no points -C at all, although this could be the -C case.) -C -C 4 Usage error occurred. The value -C of MDW is .LT. ME+MA+MG, MDW is -C .LT. N and a covariance matrix is -C requested, or the option vector -C PRGOPT(*) is not properly defined, -C or the lengths of the working arrays -C WS(*) and IP(*), when specified in -C IP(1) and IP(2) respectively, are not -C long enough. -C -C W(*,*) The array W(*,*) contains the N by N symmetric -C covariance matrix of the solution parameters, -C provided this was requested on input with -C the option vector PRGOPT(*) and the output -C flag is returned with MODE = 0 or 1. -C -C IP(*) The integer working array has three entries -C that provide rank and working array length -C information after completion. -C -C IP(1) = rank of equality constraint -C matrix. Define this quantity -C as KRANKE. -C -C IP(2) = rank of reduced least squares -C problem. -C -C IP(3) = the amount of storage in the -C working array WS(*) that was -C actually used by the subprogram. -C The formula given above for the length -C of WS(*) is a necessary overestimate. -C If exactly the same problem matrices -C are used in subsequent executions, -C the declared dimension of WS(*) can -C be reduced to this output value. -C User Designated -C Working Arrays.. -C -C WS(*),IP(*) These are respectively type real -C and type integer working arrays. -C Their required minimal lengths are -C given above. -C -C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Report SAND77-0552, Sandia -C Laboratories, June 1978. -C K. H. Haskell and R. J. Hanson, Selected algorithms for -C the linearly constrained least squares problem - a -C users guide, Report SAND78-1290, Sandia Laboratories, -C August 1979. -C K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Mathematical Programming -C 21 (1981), pp. 98-118. -C R. J. Hanson and K. H. Haskell, Two algorithms for the -C linearly constrained least squares problem, ACM -C Transactions on Mathematical Software, September 1982. -C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, -C DNRM2, DSCAL, DSWAP, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and extensively revised (WRB & RWC) -C 890831 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 900604 DP version created from SP version. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Removed prints and replaced DP --> DOUBLE PRECISION. (THC) -C***END PROLOGUE DLSEI - - INTEGER IP(3), MA, MDW, ME, MG, MODE, N - DOUBLE PRECISION PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*) -C - EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, DNRM2, - * DSCAL, DSWAP - DOUBLE PRECISION D1MACH, DASUM, DDOT, DNRM2 -C - DOUBLE PRECISION DRELPR, ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, - * SN, SNMAX, T, TAU, UJ, UP, VJ, XNORM, XNRME - INTEGER I, IMAX, J, JP1, K, KEY, KRANKE, LAST, LCHK, LINK, M, - * MAPKE1, MDEQC, MEND, MEP1, N1, N2, NEXT, NLINK, NOPT, NP1, - * NTIMES - LOGICAL COV, FIRST -C CHARACTER*8 XERN1, XERN2, XERN3, XERN4 - SAVE FIRST, DRELPR -C - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DLSEI -C -C Set the nominal tolerance used in the code for the equality -C constraint equations. -C - IF (FIRST) DRELPR = D1MACH(4) - FIRST = .FALSE. - TAU = SQRT(DRELPR) -C -C Check that enough storage was allocated in WS(*) and IP(*). -C - MODE = 4 - IF (MIN(N,ME,MA,MG) .LT. 0) THEN -C WRITE (XERN1, '(I8)') N -C WRITE (XERN2, '(I8)') ME -C WRITE (XERN3, '(I8)') MA -C WRITE (XERN4, '(I8)') MG -C CALL XERMSG ('SLATEC', 'LSEI', 'ALL OF THE VARIABLES N, ME,' // -C * ' MA, MG MUST BE .GE. 0$$ENTERED ROUTINE WITH' // -C * '$$N = ' // XERN1 // -C * '$$ME = ' // XERN2 // -C * '$$MA = ' // XERN3 // -C * '$$MG = ' // XERN4, 2, 1) - RETURN - ENDIF -C - IF (IP(1).GT.0) THEN - LCHK = 2*(ME+N) + MAX(MA+MG,N) + (MG+2)*(N+7) - IF (IP(1).LT.LCHK) THEN -C WRITE (XERN1, '(I8)') LCHK -C CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // -C * 'ALLOCATED FOR WS(*), NEED LW = ' // XERN1, 2, 1) - RETURN - ENDIF - ENDIF -C - IF (IP(2).GT.0) THEN - LCHK = MG + 2*N + 2 - IF (IP(2).LT.LCHK) THEN -C WRITE (XERN1, '(I8)') LCHK -C CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // -C * 'ALLOCATED FOR IP(*), NEED LIP = ' // XERN1, 2, 1) - RETURN - ENDIF - ENDIF -C -C Compute number of possible right multiplying Householder -C transformations. -C - M = ME + MA + MG - IF (N.LE.0 .OR. M.LE.0) THEN - MODE = 0 - RNORME = 0 - RNORML = 0 - RETURN - ENDIF -C - IF (MDW.LT.M) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', 'MDW.LT.ME+MA+MG IS AN ERROR', -C + 2, 1) - RETURN - ENDIF -C - NP1 = N + 1 - KRANKE = MIN(ME,N) - N1 = 2*KRANKE + 1 - N2 = N1 + N -C -C Set nominal values. -C -C The nominal column scaling used in the code is -C the identity scaling. -C - CALL DCOPY (N, 1.D0, 0, WS(N1), 1) -C -C No covariance matrix is nominally computed. -C - COV = .FALSE. -C -C Process option vector. -C Define bound for number of options to change. -C - NOPT = 1000 - NTIMES = 0 -C -C Define bound for positive values of LINK. -C - NLINK = 100000 - LAST = 1 - LINK = PRGOPT(1) - IF (LINK.EQ.0 .OR. LINK.GT.NLINK) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', -C + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) - RETURN - ENDIF -C - 100 IF (LINK.GT.1) THEN - NTIMES = NTIMES + 1 - IF (NTIMES.GT.NOPT) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', -C + 'THE LINKS IN THE OPTION VECTOR ARE CYCLING.', 2, 1) - RETURN - ENDIF -C - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.1) THEN - COV = PRGOPT(LAST+2) .NE. 0.D0 - ELSEIF (KEY.EQ.2 .AND. PRGOPT(LAST+2).NE.0.D0) THEN - DO 110 J = 1,N - T = DNRM2(M,W(1,J),1) - IF (T.NE.0.D0) T = 1.D0/T - WS(J+N1-1) = T - 110 CONTINUE - ELSEIF (KEY.EQ.3) THEN - CALL DCOPY (N, PRGOPT(LAST+2), 1, WS(N1), 1) - ELSEIF (KEY.EQ.4) THEN - TAU = MAX(DRELPR,PRGOPT(LAST+2)) - ENDIF -C - NEXT = PRGOPT(LINK) - IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', -C + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) - RETURN - ENDIF -C - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C - DO 120 J = 1,N - CALL DSCAL (M, WS(N1+J-1), W(1,J), 1) - 120 CONTINUE -C - IF (COV .AND. MDW.LT.N) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', -C + 'MDW .LT. N WHEN COV MATRIX NEEDED, IS AN ERROR', 2, 1) - RETURN - ENDIF -C -C Problem definition and option vector OK. -C - MODE = 0 -C -C Compute norm of equality constraint matrix and right side. -C - ENORM = 0.D0 - DO 130 J = 1,N - ENORM = MAX(ENORM,DASUM(ME,W(1,J),1)) - 130 CONTINUE -C - FNORM = DASUM(ME,W(1,NP1),1) - SNMAX = 0.D0 - RNMAX = 0.D0 - DO 150 I = 1,KRANKE -C -C Compute maximum ratio of vector lengths. Partition is at -C column I. -C - DO 140 K = I,ME - SN = DDOT(N-I+1,W(K,I),MDW,W(K,I),MDW) - RN = DDOT(I-1,W(K,1),MDW,W(K,1),MDW) - IF (RN.EQ.0.D0 .AND. SN.GT.SNMAX) THEN - SNMAX = SN - IMAX = K - ELSEIF (K.EQ.I .OR. SN*RNMAX.GT.RN*SNMAX) THEN - SNMAX = SN - RNMAX = RN - IMAX = K - ENDIF - 140 CONTINUE -C -C Interchange rows if necessary. -C - IF (I.NE.IMAX) CALL DSWAP (NP1, W(I,1), MDW, W(IMAX,1), MDW) - IF (SNMAX.GT.RNMAX*TAU**2) THEN -C -C Eliminate elements I+1,...,N in row I. -C - CALL DH12 (1, I, I+1, N, W(I,1), MDW, WS(I), W(I+1,1), MDW, - + 1, M-I) - ELSE - KRANKE = I - 1 - GO TO 160 - ENDIF - 150 CONTINUE -C -C Save diagonal terms of lower trapezoidal matrix. -C - 160 CALL DCOPY (KRANKE, W, MDW+1, WS(KRANKE+1), 1) -C -C Use Householder transformation from left to achieve -C KRANKE by KRANKE upper triangular form. -C - IF (KRANKE.LT.ME) THEN - DO 170 K = KRANKE,1,-1 -C -C Apply transformation to matrix cols. 1,...,K-1. -C - CALL DH12 (1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, - * K-1) -C -C Apply to rt side vector. -C - CALL DH12 (2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, - + 1, 1) - 170 CONTINUE - ENDIF -C -C Solve for variables 1,...,KRANKE in new coordinates. -C - CALL DCOPY (KRANKE, W(1, NP1), 1, X, 1) - DO 180 I = 1,KRANKE - X(I) = (X(I)-DDOT(I-1,W(I,1),MDW,X,1))/W(I,I) - 180 CONTINUE -C -C Compute residuals for reduced problem. -C - MEP1 = ME + 1 - RNORML = 0.D0 - DO 190 I = MEP1,M - W(I,NP1) = W(I,NP1) - DDOT(KRANKE,W(I,1),MDW,X,1) - SN = DDOT(KRANKE,W(I,1),MDW,W(I,1),MDW) - RN = DDOT(N-KRANKE,W(I,KRANKE+1),MDW,W(I,KRANKE+1),MDW) - IF (RN.LE.SN*TAU**2 .AND. KRANKE.LT.N) - * CALL DCOPY (N-KRANKE, 0.D0, 0, W(I,KRANKE+1), MDW) - 190 CONTINUE -C -C Compute equality constraint equations residual length. -C - RNORME = DNRM2(ME-KRANKE,W(KRANKE+1,NP1),1) -C -C Move reduced problem data upward if KRANKE.LT.ME. -C - IF (KRANKE.LT.ME) THEN - DO 200 J = 1,NP1 - CALL DCOPY (M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1) - 200 CONTINUE - ENDIF -C -C Compute solution of reduced problem. -C - CALL DLSI(W(KRANKE+1, KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT, - + X(KRANKE+1), RNORML, MODE, WS(N2), IP(2)) -C -C Test for consistency of equality constraints. -C - IF (ME.GT.0) THEN - MDEQC = 0 - XNRME = DASUM(KRANKE,W(1,NP1),1) - IF (RNORME.GT.TAU*(ENORM*XNRME+FNORM)) MDEQC = 1 - MODE = MODE + MDEQC -C -C Check if solution to equality constraints satisfies inequality -C constraints when there are no degrees of freedom left. -C - IF (KRANKE.EQ.N .AND. MG.GT.0) THEN - XNORM = DASUM(N,X,1) - MAPKE1 = MA + KRANKE + 1 - MEND = MA + KRANKE + MG - DO 210 I = MAPKE1,MEND - SIZE = DASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1)) - IF (W(I,NP1).GT.TAU*SIZE) THEN - MODE = MODE + 2 - GO TO 290 - ENDIF - 210 CONTINUE - ENDIF - ENDIF -C -C Replace diagonal terms of lower trapezoidal matrix. -C - IF (KRANKE.GT.0) THEN - CALL DCOPY (KRANKE, WS(KRANKE+1), 1, W, MDW+1) -C -C Reapply transformation to put solution in original coordinates. -C - DO 220 I = KRANKE,1,-1 - CALL DH12 (2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1) - 220 CONTINUE -C -C Compute covariance matrix of equality constrained problem. -C - IF (COV) THEN - DO 270 J = MIN(KRANKE,N-1),1,-1 - RB = WS(J)*W(J,J) - IF (RB.NE.0.D0) RB = 1.D0/RB - JP1 = J + 1 - DO 230 I = JP1,N - W(I,J) = RB*DDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW) - 230 CONTINUE -C - GAM = 0.5D0*RB*DDOT(N-J,W(JP1,J),1,W(J,JP1),MDW) - CALL DAXPY (N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1) - DO 250 I = JP1,N - DO 240 K = I,N - W(I,K) = W(I,K) + W(J,I)*W(K,J) + W(I,J)*W(J,K) - W(K,I) = W(I,K) - 240 CONTINUE - 250 CONTINUE - UJ = WS(J) - VJ = GAM*UJ - W(J,J) = UJ*VJ + UJ*VJ - DO 260 I = JP1,N - W(J,I) = UJ*W(I,J) + VJ*W(J,I) - 260 CONTINUE - CALL DCOPY (N-J, W(J, JP1), MDW, W(JP1,J), 1) - 270 CONTINUE - ENDIF - ENDIF -C -C Apply the scaling to the covariance matrix. -C - IF (COV) THEN - DO 280 I = 1,N - CALL DSCAL (N, WS(I+N1-1), W(I,1), MDW) - CALL DSCAL (N, WS(I+N1-1), W(1,I), 1) - 280 CONTINUE - ENDIF -C -C Rescale solution vector. -C - 290 IF (MODE.LE.1) THEN - DO 300 J = 1,N - X(J) = X(J)*WS(N1+J-1) - 300 CONTINUE - ENDIF -C - IP(1) = KRANKE - IP(3) = IP(3) + 2*KRANKE + N - RETURN - END -*DECK DLSI - SUBROUTINE DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, - + IP) -C***BEGIN PROLOGUE DLSI -C***SUBSIDIARY -C***PURPOSE Subsidiary to DLSEI -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (LSI-S, DLSI-D) -C***AUTHOR Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to DLSEI. The documentation for -C DLSEI has complete usage instructions. -C -C Solve.. -C AX = B, A MA by N (least squares equations) -C subject to.. -C -C GX.GE.H, G MG by N (inequality constraints) -C -C Input.. -C -C W(*,*) contains (A B) in rows 1,...,MA+MG, cols 1,...,N+1. -C (G H) -C -C MDW,MA,MG,N -C contain (resp) var. dimension of W(*,*), -C and matrix dimensions. -C -C PRGOPT(*), -C Program option vector. -C -C OUTPUT.. -C -C X(*),RNORM -C -C Solution vector(unless MODE=2), length of AX-B. -C -C MODE -C =0 Inequality constraints are compatible. -C =2 Inequality constraints contradictory. -C -C WS(*), -C Working storage of dimension K+N+(MG+2)*(N+7), -C where K=MAX(MA+MG,N). -C IP(MG+2*N+1) -C Integer working storage -C -C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, -C DLPDP, DSCAL, DSWAP -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and extensively revised (WRB & RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900604 DP version created from SP version. (RWC) -C 920422 Changed CALL to DHFTI to include variable MA. (WRB) -C***END PROLOGUE DLSI - - INTEGER IP(*), MA, MDW, MG, MODE, N - DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*) -C - EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, DLPDP, - * DSCAL, DSWAP - DOUBLE PRECISION D1MACH, DASUM, DDOT -C - DOUBLE PRECISION ANORM, DRELPR, FAC, GAM, RB, TAU, TOL, XNORM, - * TMP_NORM(1) - INTEGER I, J, K, KEY, KRANK, KRM1, KRP1, L, LAST, LINK, M, MAP1, - * MDLPDP, MINMAN, N1, N2, N3, NEXT, NP1 - LOGICAL COV, FIRST, SCLCOV -C - SAVE DRELPR, FIRST - DATA FIRST /.TRUE./ -C -C***FIRST EXECUTABLE STATEMENT DLSI -C -C Set the nominal tolerance used in the code. -C - IF (FIRST) DRELPR = D1MACH(4) - FIRST = .FALSE. - TOL = SQRT(DRELPR) -C - MODE = 0 - RNORM = 0.D0 - M = MA + MG - NP1 = N + 1 - KRANK = 0 - IF (N.LE.0 .OR. M.LE.0) GO TO 370 -C -C To process option vector. -C - COV = .FALSE. - SCLCOV = .TRUE. - LAST = 1 - LINK = PRGOPT(1) -C - 100 IF (LINK.GT.1) THEN - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.1) COV = PRGOPT(LAST+2) .NE. 0.D0 - IF (KEY.EQ.10) SCLCOV = PRGOPT(LAST+2) .EQ. 0.D0 - IF (KEY.EQ.5) TOL = MAX(DRELPR,PRGOPT(LAST+2)) - NEXT = PRGOPT(LINK) - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C -C Compute matrix norm of least squares equations. -C - ANORM = 0.D0 - DO 110 J = 1,N - ANORM = MAX(ANORM,DASUM(MA,W(1,J),1)) - 110 CONTINUE -C -C Set tolerance for DHFTI( ) rank test. -C - TAU = TOL*ANORM -C -C Compute Householder orthogonal decomposition of matrix. -C - CALL DCOPY (N, 0.D0, 0, WS, 1) - CALL DCOPY (MA, W(1, NP1), 1, WS, 1) - K = MAX(M,N) - MINMAN = MIN(MA,N) - N1 = K + 1 - N2 = N1 + N - CALL DHFTI (W, MDW, MA, N, WS, MA, 1, TAU, KRANK, TMP_NORM, - + WS(N2), WS(N1), IP) - RNORM = TMP_NORM(1) - FAC = 1.D0 - GAM = MA - KRANK - IF (KRANK.LT.MA .AND. SCLCOV) FAC = RNORM**2/GAM -C -C Reduce to DLPDP and solve. -C - MAP1 = MA + 1 -C -C Compute inequality rt-hand side for DLPDP. -C - IF (MA.LT.M) THEN - IF (MINMAN.GT.0) THEN - DO 120 I = MAP1,M - W(I,NP1) = W(I,NP1) - DDOT(N,W(I,1),MDW,WS,1) - 120 CONTINUE -C -C Apply permutations to col. of inequality constraint matrix. -C - DO 130 I = 1,MINMAN - CALL DSWAP (MG, W(MAP1,I), 1, W(MAP1,IP(I)), 1) - 130 CONTINUE -C -C Apply Householder transformations to constraint matrix. -C - IF (KRANK.GT.0 .AND. KRANK.LT.N) THEN - DO 140 I = KRANK,1,-1 - CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), - + W(MAP1,1), MDW, 1, MG) - 140 CONTINUE - ENDIF -C -C Compute permuted inequality constraint matrix times r-inv. -C - DO 160 I = MAP1,M - DO 150 J = 1,KRANK - W(I,J) = (W(I,J)-DDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J) - 150 CONTINUE - 160 CONTINUE - ENDIF -C -C Solve the reduced problem with DLPDP algorithm, -C the least projected distance problem. -C - CALL DLPDP(W(MAP1,1), MDW, MG, KRANK, N-KRANK, PRGOPT, X, - + XNORM, MDLPDP, WS(N2), IP(N+1)) -C -C Compute solution in original coordinates. -C - IF (MDLPDP.EQ.1) THEN - DO 170 I = KRANK,1,-1 - X(I) = (X(I)-DDOT(KRANK-I,W(I,I+1),MDW,X(I+1),1))/W(I,I) - 170 CONTINUE -C -C Apply Householder transformation to solution vector. -C - IF (KRANK.LT.N) THEN - DO 180 I = 1,KRANK - CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), - + X, 1, 1, 1) - 180 CONTINUE - ENDIF -C -C Repermute variables to their input order. -C - IF (MINMAN.GT.0) THEN - DO 190 I = MINMAN,1,-1 - CALL DSWAP (1, X(I), 1, X(IP(I)), 1) - 190 CONTINUE -C -C Variables are now in original coordinates. -C Add solution of unconstrained problem. -C - DO 200 I = 1,N - X(I) = X(I) + WS(I) - 200 CONTINUE -C -C Compute the residual vector norm. -C - RNORM = SQRT(RNORM**2+XNORM**2) - ENDIF - ELSE - MODE = 2 - ENDIF - ELSE - CALL DCOPY (N, WS, 1, X, 1) - ENDIF -C -C Compute covariance matrix based on the orthogonal decomposition -C from DHFTI( ). -C - IF (.NOT.COV .OR. KRANK.LE.0) GO TO 370 - KRM1 = KRANK - 1 - KRP1 = KRANK + 1 -C -C Copy diagonal terms to working array. -C - CALL DCOPY (KRANK, W, MDW+1, WS(N2), 1) -C -C Reciprocate diagonal terms. -C - DO 210 J = 1,KRANK - W(J,J) = 1.D0/W(J,J) - 210 CONTINUE -C -C Invert the upper triangular QR factor on itself. -C - IF (KRANK.GT.1) THEN - DO 230 I = 1,KRM1 - DO 220 J = I+1,KRANK - W(I,J) = -DDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J) - 220 CONTINUE - 230 CONTINUE - ENDIF -C -C Compute the inverted factor times its transpose. -C - DO 250 I = 1,KRANK - DO 240 J = I,KRANK - W(I,J) = DDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW) - 240 CONTINUE - 250 CONTINUE -C -C Zero out lower trapezoidal part. -C Copy upper triangular to lower triangular part. -C - IF (KRANK.LT.N) THEN - DO 260 J = 1,KRANK - CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) - 260 CONTINUE -C - DO 270 I = KRP1,N - CALL DCOPY (I, 0.D0, 0, W(I,1), MDW) - 270 CONTINUE -C -C Apply right side transformations to lower triangle. -C - N3 = N2 + KRP1 - DO 330 I = 1,KRANK - L = N1 + I - K = N2 + I - RB = WS(L-1)*WS(K-1) -C -C If RB.GE.0.D0, transformation can be regarded as zero. -C - IF (RB.LT.0.D0) THEN - RB = 1.D0/RB -C -C Store unscaled rank one Householder update in work array. -C - CALL DCOPY (N, 0.D0, 0, WS(N3), 1) - L = N1 + I - K = N3 + I - WS(K-1) = WS(L-1) -C - DO 280 J = KRP1,N - WS(N3+J-1) = W(I,J) - 280 CONTINUE -C - DO 290 J = 1,N - WS(J) = RB*(DDOT(J-I,W(J,I),MDW,WS(N3+I-1),1)+ - + DDOT(N-J+1,W(J,J),1,WS(N3+J-1),1)) - 290 CONTINUE -C - L = N3 + I - GAM = 0.5D0*RB*DDOT(N-I+1,WS(L-1),1,WS(I),1) - CALL DAXPY (N-I+1, GAM, WS(L-1), 1, WS(I), 1) - DO 320 J = I,N - DO 300 L = 1,I-1 - W(J,L) = W(J,L) + WS(N3+J-1)*WS(L) - 300 CONTINUE -C - DO 310 L = I,J - W(J,L) = W(J,L) + WS(J)*WS(N3+L-1)+WS(L)*WS(N3+J-1) - 310 CONTINUE - 320 CONTINUE - ENDIF - 330 CONTINUE -C -C Copy lower triangle to upper triangle to symmetrize the -C covariance matrix. -C - DO 340 I = 1,N - CALL DCOPY (I, W(I,1), MDW, W(1,I), 1) - 340 CONTINUE - ENDIF -C -C Repermute rows and columns. -C - DO 350 I = MINMAN,1,-1 - K = IP(I) - IF (I.NE.K) THEN - CALL DSWAP (1, W(I,I), 1, W(K,K), 1) - CALL DSWAP (I-1, W(1,I), 1, W(1,K), 1) - CALL DSWAP (K-I-1, W(I,I+1), MDW, W(I+1,K), 1) - CALL DSWAP (N-K, W(I, K+1), MDW, W(K, K+1), MDW) - ENDIF - 350 CONTINUE -C -C Put in normalized residual sum of squares scale factor -C and symmetrize the resulting covariance matrix. -C - DO 360 J = 1,N - CALL DSCAL (J, FAC, W(1,J), 1) - CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) - 360 CONTINUE -C - 370 IP(1) = KRANK - IP(2) = N + MAX(M,N) + (MG+2)*(N+7) - RETURN - END -*DECK D1MACH - DOUBLE PRECISION FUNCTION D1MACH (I) -C***BEGIN PROLOGUE D1MACH -C***PURPOSE Return floating point machine dependent constants. -C***LIBRARY SLATEC -C***CATEGORY R1 -C***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR Fox, P. A., (Bell Labs) -C Hall, A. D., (Bell Labs) -C Schryer, N. L., (Bell Labs) -C***DESCRIPTION -C -C D1MACH can be used to obtain machine-dependent parameters for the -C local machine environment. It is a function subprogram with one -C (input) argument, and can be referenced as follows: -C -C D = D1MACH(I) -C -C where I=1,...,5. The (output) value of D above is determined by -C the (input) value of I. The results for various values of I are -C discussed below. -C -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 Assume double precision numbers are represented in the T-digit, -C base-B form -C -C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C -C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and -C EMIN .LE. E .LE. EMAX. -C -C The values of B, T, EMIN and EMAX are provided in I1MACH as -C follows: -C I1MACH(10) = B, the base. -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 -C To alter this function for a particular environment, the desired -C set of DATA statements should be activated by removing the C from -C column 1. Also, the values of D1MACH(1) - D1MACH(4) should be -C checked for consistency with the local operating system. -C -C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for -C a portable library, ACM Transactions on Mathematical -C Software 4, 2 (June 1978), pp. 177-188. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 890213 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900618 Added DEC RISC constants. (WRB) -C 900723 Added IBM RS 6000 constants. (WRB) -C 900911 Added SUN 386i constants. (WRB) -C 910710 Added HP 730 constants. (SMR) -C 911114 Added Convex IEEE constants. (WRB) -C 920121 Added SUN -r8 compiler option constants. (WRB) -C 920229 Added Touchstone Delta i860 constants. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920625 Added CONVEX -p8 and -pd8 compiler option constants. -C (BKS, WRB) -C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) -C 010817 Elevated IEEE to highest importance; see next set of -C comments below. (DWL) -C***END PROLOGUE D1MACH -C - - INTEGER SMALL(4) - INTEGER LARGE(4) - INTEGER RIGHT(4) - INTEGER DIVER(4) - INTEGER LOG10(4) -C -C Initial data here correspond to the IEEE standard. The values for -C DMACH(1), DMACH(3) and DMACH(4) are slight upper bounds. The value -C for DMACH(2) is a slight lower bound. The value for DMACH(5) is -C a 20-digit approximation. If one of the sets of initial data below -C is preferred, do the necessary commenting and uncommenting. (DWL) - DOUBLE PRECISION DMACH(5) - DATA DMACH / 2.23D-308, 1.79D+308, 1.111D-16, 2.222D-16, - 1 0.30102999566398119521D0 / - SAVE DMACH -C - 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 AMIGA -C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE APOLLO -C -C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / -C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / -C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / -C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM -C -C DATA SMALL(1) / ZC00800000 / -C DATA SMALL(2) / Z000000000 / -C DATA LARGE(1) / ZDFFFFFFFF / -C DATA LARGE(2) / ZFFFFFFFFF / -C DATA RIGHT(1) / ZCC5800000 / -C DATA RIGHT(2) / Z000000000 / -C DATA DIVER(1) / ZCC6800000 / -C DATA DIVER(2) / Z000000000 / -C DATA LOG10(1) / ZD00E730E7 / -C DATA LOG10(2) / ZC77800DC0 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM -C -C DATA SMALL(1) / O1771000000000000 / -C DATA SMALL(2) / O0000000000000000 / -C DATA LARGE(1) / O0777777777777777 / -C DATA LARGE(2) / O0007777777777777 / -C DATA RIGHT(1) / O1461000000000000 / -C DATA RIGHT(2) / O0000000000000000 / -C DATA DIVER(1) / O1451000000000000 / -C DATA DIVER(2) / O0000000000000000 / -C DATA LOG10(1) / O1157163034761674 / -C DATA LOG10(2) / O0006677466732724 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS -C -C DATA SMALL(1) / O1771000000000000 / -C DATA SMALL(2) / O7770000000000000 / -C DATA LARGE(1) / O0777777777777777 / -C DATA LARGE(2) / O7777777777777777 / -C DATA RIGHT(1) / O1461000000000000 / -C DATA RIGHT(2) / O0000000000000000 / -C DATA DIVER(1) / O1451000000000000 / -C DATA DIVER(2) / O0000000000000000 / -C DATA LOG10(1) / O1157163034761674 / -C DATA LOG10(2) / O0006677466732724 / -C -C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE -C -C DATA SMALL(1) / Z"3001800000000000" / -C DATA SMALL(2) / Z"3001000000000000" / -C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / -C DATA LARGE(2) / Z"4FFE000000000000" / -C DATA RIGHT(1) / Z"3FD2800000000000" / -C DATA RIGHT(2) / Z"3FD2000000000000" / -C DATA DIVER(1) / Z"3FD3800000000000" / -C DATA DIVER(2) / Z"3FD3000000000000" / -C DATA LOG10(1) / Z"3FFF9A209A84FBCF" / -C DATA LOG10(2) / Z"3FFFF7988F8959AC" / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES -C -C DATA SMALL(1) / 00564000000000000000B / -C DATA SMALL(2) / 00000000000000000000B / -C DATA LARGE(1) / 37757777777777777777B / -C DATA LARGE(2) / 37157777777777777777B / -C DATA RIGHT(1) / 15624000000000000000B / -C DATA RIGHT(2) / 00000000000000000000B / -C DATA DIVER(1) / 15634000000000000000B / -C DATA DIVER(2) / 00000000000000000000B / -C DATA LOG10(1) / 17164642023241175717B / -C DATA LOG10(2) / 16367571421742254654B / -C -C MACHINE CONSTANTS FOR THE CELERITY C1260 -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fn OR -pd8 COMPILER OPTION -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CC0000000000000' / -C DATA DMACH(4) / Z'3CD0000000000000' / -C DATA DMACH(5) / Z'3FF34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fi COMPILER OPTION -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -p8 COMPILER OPTION -C -C DATA DMACH(1) / Z'00010000000000000000000000000000' / -C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3F900000000000000000000000000000' / -C DATA DMACH(4) / Z'3F910000000000000000000000000000' / -C DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / -C -C MACHINE CONSTANTS FOR THE CRAY -C -C DATA SMALL(1) / 201354000000000000000B / -C DATA SMALL(2) / 000000000000000000000B / -C DATA LARGE(1) / 577767777777777777777B / -C DATA LARGE(2) / 000007777777777777774B / -C DATA RIGHT(1) / 376434000000000000000B / -C DATA RIGHT(2) / 000000000000000000000B / -C DATA DIVER(1) / 376444000000000000000B / -C DATA DIVER(2) / 000000000000000000000B / -C DATA LOG10(1) / 377774642023241175717B / -C DATA LOG10(2) / 000007571421742254654B / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - -C STATIC DMACH(5) -C -C DATA SMALL / 20K, 3*0 / -C DATA LARGE / 77777K, 3*177777K / -C DATA RIGHT / 31420K, 3*0 / -C DATA DIVER / 32020K, 3*0 / -C DATA LOG10 / 40423K, 42023K, 50237K, 74776K / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING G_FLOAT -C -C DATA DMACH(1) / '0000000000000010'X / -C DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / -C DATA DMACH(3) / '0000000000003CC0'X / -C DATA DMACH(4) / '0000000000003CD0'X / -C DATA DMACH(5) / '79FF509F44133FF3'X / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING IEEE_FORMAT -C -C DATA DMACH(1) / '0010000000000000'X / -C DATA DMACH(2) / '7FEFFFFFFFFFFFFF'X / -C DATA DMACH(3) / '3CA0000000000000'X / -C DATA DMACH(4) / '3CB0000000000000'X / -C DATA DMACH(5) / '3FD34413509F79FF'X / -C -C MACHINE CONSTANTS FOR THE DEC RISC -C -C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ -C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ -C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ -C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ -C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING D_FLOATING -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS -C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS -C -C DATA SMALL(1), SMALL(2) / 128, 0 / -C DATA LARGE(1), LARGE(2) / -32769, -1 / -C DATA RIGHT(1), RIGHT(2) / 9344, 0 / -C DATA DIVER(1), DIVER(2) / 9472, 0 / -C DATA LOG10(1), LOG10(2) / 546979738, -805796613 / -C -C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / -C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING G_FLOATING -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS -C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS -C -C DATA SMALL(1), SMALL(2) / 16, 0 / -C DATA LARGE(1), LARGE(2) / -32769, -1 / -C DATA RIGHT(1), RIGHT(2) / 15552, 0 / -C DATA DIVER(1), DIVER(2) / 15568, 0 / -C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / -C -C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / -C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / -C -C MACHINE CONSTANTS FOR THE ELXSI 6400 -C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) -C -C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / -C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / -C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / -C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / -C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C -C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / -C DATA LARGE(1), LARGE(2) / '37777777, '37777577 / -C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / -C DATA DIVER(1), DIVER(2) / '20000000, '00000334 / -C DATA LOG10(1), LOG10(2) / '23210115, '10237777 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES -C -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 / -C -C MACHINE CONSTANTS FOR THE HP 730 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / -C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / -C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / -C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / -C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA SMALL(1), SMALL(2) / 40000B, 0 / -C DATA SMALL(3), SMALL(4) / 0, 1 / -C DATA LARGE(1), LARGE(2) / 77777B, 177777B / -C DATA LARGE(3), LARGE(4) / 177777B, 177776B / -C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / -C DATA RIGHT(3), RIGHT(4) / 0, 225B / -C DATA DIVER(1), DIVER(2) / 40000B, 0 / -C DATA DIVER(3), DIVER(4) / 0, 227B / -C DATA LOG10(1), LOG10(2) / 46420B, 46502B / -C DATA LOG10(3), LOG10(4) / 76747B, 176377B / -C -C MACHINE CONSTANTS FOR THE HP 9000 -C -C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / -C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / -C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / -C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / -C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND -C THE PERKIN ELMER (INTERDATA) 7/32. -C -C DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / -C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / -C -C MACHINE CONSTANTS FOR THE IBM PC -C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION -C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. -C -C DATA SMALL(1) / 2.23D-308 / -C DATA LARGE(1) / 1.79D+308 / -C DATA RIGHT(1) / 1.11D-16 / -C DATA DIVER(1) / 2.22D-16 / -C DATA LOG10(1) / 0.301029995663981195D0 / -C -C MACHINE CONSTANTS FOR THE IBM RS 6000 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE INTEL i860 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) -C -C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / -C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / -C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / -C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / -C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) -C -C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / -C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / -C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / -C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / -C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -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 / -C -C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / -C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / -C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / -C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / -C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA SMALL(1), SMALL(2) / 128, 0 / -C DATA SMALL(3), SMALL(4) / 0, 0 / -C DATA LARGE(1), LARGE(2) / 32767, -1 / -C DATA LARGE(3), LARGE(4) / -1, -1 / -C DATA RIGHT(1), RIGHT(2) / 9344, 0 / -C DATA RIGHT(3), RIGHT(4) / 0, 0 / -C DATA DIVER(1), DIVER(2) / 9472, 0 / -C DATA DIVER(3), DIVER(4) / 0, 0 / -C DATA LOG10(1), LOG10(2) / 16282, 8346 / -C DATA LOG10(3), LOG10(4) / -31493, -12296 / -C -C DATA SMALL(1), SMALL(2) / O000200, O000000 / -C DATA SMALL(3), SMALL(4) / O000000, O000000 / -C DATA LARGE(1), LARGE(2) / O077777, O177777 / -C DATA LARGE(3), LARGE(4) / O177777, O177777 / -C DATA RIGHT(1), RIGHT(2) / O022200, O000000 / -C DATA RIGHT(3), RIGHT(4) / O000000, O000000 / -C DATA DIVER(1), DIVER(2) / O022400, O000000 / -C DATA DIVER(3), DIVER(4) / O000000, O000000 / -C DATA LOG10(1), LOG10(2) / O037632, O020232 / -C DATA LOG10(3), LOG10(4) / O102373, O147770 / -C -C MACHINE CONSTANTS FOR THE SILICON GRAPHICS -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE SUN -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE SUN -C USING THE -r8 COMPILER OPTION -C -C DATA DMACH(1) / Z'00010000000000000000000000000000' / -C DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / -C DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / -C DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / -C -C MACHINE CONSTANTS FOR THE SUN 386i -C -C DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / -C DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / -C DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' -C DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER -C -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 / -C -C***FIRST EXECUTABLE STATEMENT D1MACH -C IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'D1MACH', -C + 'I OUT OF BOUNDS', 1, 2) -C - D1MACH = DMACH(I) - RETURN -C - END -*DECK I1MACH - INTEGER FUNCTION I1MACH (I) -C***BEGIN PROLOGUE I1MACH -C***PURPOSE Return integer machine dependent constants. -C***LIBRARY SLATEC -C***CATEGORY R1 -C***TYPE INTEGER (I1MACH-I) -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR Fox, P. A., (Bell Labs) -C Hall, A. D., (Bell Labs) -C Schryer, N. L., (Bell Labs) -C***DESCRIPTION -C -C I1MACH can be used to obtain machine-dependent parameters for the -C local machine environment. It is a function subprogram with one -C (input) argument and can be referenced as follows: -C -C K = I1MACH(I) -C -C where I=1,...,16. The (output) value of K above is determined by -C the (input) value of I. The results for various values of I are -C discussed below. -C -C I/O unit numbers: -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 -C Words: -C I1MACH( 5) = the number of bits per integer storage unit. -C I1MACH( 6) = the number of characters per integer storage unit. -C -C Integers: -C assume integers are represented in the S-digit, base-A form -C -C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) -C -C where 0 .LE. X(I) .LT. A for I=0,...,S-1. -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 -C Floating-Point Numbers: -C Assume floating-point numbers are represented in the T-digit, -C base-B form -C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C -C where 0 .LE. X(I) .LT. B for I=1,...,T, -C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. -C I1MACH(10) = B, the base. -C -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 -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 -C To alter this function for a particular environment, the desired -C set of DATA statements should be activated by removing the C from -C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be -C checked for consistency with the local operating system. -C -C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for -C a portable library, ACM Transactions on Mathematical -C Software 4, 2 (June 1978), pp. 177-188. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 891012 Added VAX G-floating constants. (WRB) -C 891012 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900618 Added DEC RISC constants. (WRB) -C 900723 Added IBM RS 6000 constants. (WRB) -C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. -C (RWC) -C 910710 Added HP 730 constants. (SMR) -C 911114 Added Convex IEEE constants. (WRB) -C 920121 Added SUN -r8 compiler option constants. (WRB) -C 920229 Added Touchstone Delta i860 constants. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920625 Added Convex -p8 and -pd8 compiler option constants. -C (BKS, WRB) -C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) -C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler -C options. (DWL, RWC and WRB). -C 010817 Elevated IEEE to highest importance; see next set of -C comments below. (DWL) -C***END PROLOGUE I1MACH -C -C Initial data here correspond to the IEEE standard. If one of the -C sets of initial data below is preferred, do the necessary commenting -C and uncommenting. (DWL) - INTEGER IMACH(16),OUTPUT - DATA IMACH( 1) / 5 / - DATA IMACH( 2) / 6 / - DATA IMACH( 3) / 6 / - DATA IMACH( 4) / 6 / - DATA IMACH( 5) / 32 / - DATA IMACH( 6) / 4 / - DATA IMACH( 7) / 2 / - DATA IMACH( 8) / 31 / - DATA IMACH( 9) / 2147483647 / - DATA IMACH(10) / 2 / - DATA IMACH(11) / 24 / - DATA IMACH(12) / -126 / - DATA IMACH(13) / 127 / - DATA IMACH(14) / 53 / - DATA IMACH(15) / -1022 / - DATA IMACH(16) / 1023 / - SAVE IMACH - EQUIVALENCE (IMACH(4),OUTPUT) -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT COMPILER -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE APOLLO -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 129 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1025 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM -C -C DATA IMACH( 1) / 7 / -C DATA IMACH( 2) / 2 / -C DATA IMACH( 3) / 2 / -C DATA IMACH( 4) / 2 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 33 / -C DATA IMACH( 9) / Z1FFFFFFFF / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -256 / -C DATA IMACH(13) / 255 / -C DATA IMACH(14) / 60 / -C DATA IMACH(15) / -256 / -C DATA IMACH(16) / 255 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM -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) / 48 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 39 / -C DATA IMACH( 9) / O0007777777777777 / -C DATA IMACH(10) / 8 / -C DATA IMACH(11) / 13 / -C DATA IMACH(12) / -50 / -C DATA IMACH(13) / 76 / -C DATA IMACH(14) / 26 / -C DATA IMACH(15) / -50 / -C DATA IMACH(16) / 76 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS -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) / 48 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 39 / -C DATA IMACH( 9) / O0007777777777777 / -C DATA IMACH(10) / 8 / -C DATA IMACH(11) / 13 / -C DATA IMACH(12) / -50 / -C DATA IMACH(13) / 76 / -C DATA IMACH(14) / 26 / -C DATA IMACH(15) / -32754 / -C DATA IMACH(16) / 32780 / -C -C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE -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) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -4095 / -C DATA IMACH(13) / 4094 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -4095 / -C DATA IMACH(16) / 4094 / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6LOUTPUT/ -C DATA IMACH( 5) / 60 / -C DATA IMACH( 6) / 10 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 48 / -C DATA IMACH( 9) / 00007777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -929 / -C DATA IMACH(13) / 1070 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -929 / -C DATA IMACH(16) / 1069 / -C -C MACHINE CONSTANTS FOR THE CELERITY C1260 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 0 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / Z'7FFFFFFF' / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fn COMPILER OPTION -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) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fi COMPILER OPTION -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -p8 COMPILER OPTION -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) / 64 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1023 / -C DATA IMACH(13) / 1023 / -C DATA IMACH(14) / 113 / -C DATA IMACH(15) / -16383 / -C DATA IMACH(16) / 16383 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -pd8 COMPILER OPTION -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) / 64 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1023 / -C DATA IMACH(13) / 1023 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CRAY -C USING THE 46 BIT INTEGER COMPILER OPTION -C -C DATA IMACH( 1) / 100 / -C DATA IMACH( 2) / 101 / -C DATA IMACH( 3) / 102 / -C DATA IMACH( 4) / 101 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 46 / -C DATA IMACH( 9) / 1777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -8189 / -C DATA IMACH(13) / 8190 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -8099 / -C DATA IMACH(16) / 8190 / -C -C MACHINE CONSTANTS FOR THE CRAY -C USING THE 64 BIT INTEGER COMPILER OPTION -C -C DATA IMACH( 1) / 100 / -C DATA IMACH( 2) / 101 / -C DATA IMACH( 3) / 102 / -C DATA IMACH( 4) / 101 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 777777777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -8189 / -C DATA IMACH(13) / 8190 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -8099 / -C DATA IMACH(16) / 8190 / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C -C DATA IMACH( 1) / 11 / -C DATA IMACH( 2) / 12 / -C DATA IMACH( 3) / 8 / -C DATA IMACH( 4) / 10 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING G_FLOAT -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING IEEE_FLOAT -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE DEC RISC -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING D_FLOATING -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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 / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING G_FLOATING -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE ELXSI 6400 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 32 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 24 / -C DATA IMACH( 6) / 3 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 23 / -C DATA IMACH( 9) / 8388607 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 38 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 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) / 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) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 63 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 730 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 4 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 39 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 4 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 55 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 9000 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 7 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 32 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1015 / -C DATA IMACH(16) / 1017 / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND -C THE PERKIN ELMER (INTERDATA) 7/32. -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) / Z7FFFFFFF / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 / -C -C MACHINE CONSTANTS FOR THE IBM PC -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 0 / -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) / -125 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE IBM RS 6000 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 0 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE INTEL i860 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 5 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / "377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 54 / -C DATA IMACH(15) / -101 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 5 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / "377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 62 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGER ARITHMETIC. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGER ARITHMETIC. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -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 / -C -C MACHINE CONSTANTS FOR THE SILICON GRAPHICS -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE SUN -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE SUN -C USING THE -r8 COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / 53 / -C DATA IMACH(12) / -1021 / -C DATA IMACH(13) / 1024 / -C DATA IMACH(14) / 113 / -C DATA IMACH(15) / -16381 / -C DATA IMACH(16) / 16384 / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 1 / -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) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 60 / -C DATA IMACH(15) / -1024 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR -C -C DATA IMACH( 1) / 1 / -C DATA IMACH( 2) / 1 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -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 / -C -C***FIRST EXECUTABLE STATEMENT I1MACH - IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 -C - I1MACH = IMACH(I) - RETURN -C - 10 CONTINUE - WRITE (UNIT = OUTPUT, FMT = 9000) - 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') -C -C CALL FDUMP -C - STOP - END -*DECK DH12 - SUBROUTINE DH12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV, - + NCV) -C***BEGIN PROLOGUE DH12 -C***SUBSIDIARY -C***PURPOSE Subsidiary to DHFTI, DLSEI and DWNNLS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (H12-S, DH12-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C *** DOUBLE PRECISION VERSION OF H12 ****** -C -C C.L.Lawson and R.J.Hanson, Jet Propulsion Laboratory, 1973 Jun 12 -C to appear in 'Solving Least Squares Problems', Prentice-Hall, 1974 -C -C Construction and/or application of a single -C Householder transformation.. Q = I + U*(U**T)/B -C -C MODE = 1 or 2 to select algorithm H1 or H2 . -C LPIVOT is the index of the pivot element. -C L1,M If L1 .LE. M the transformation will be constructed to -C zero elements indexed from L1 through M. If L1 GT. M -C THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. -C U(),IUE,UP On entry to H1 U() contains the pivot vector. -C IUE is the storage increment between elements. -C On exit from H1 U() and UP -C contain quantities defining the vector U of the -C Householder transformation. On entry to H2 U() -C and UP should contain quantities previously computed -C by H1. These will not be modified by H2. -C C() On entry to H1 or H2 C() contains a matrix which will be -C regarded as a set of vectors to which the Householder -C transformation is to be applied. On exit C() contains the -C set of transformed vectors. -C ICE Storage increment between elements of vectors in C(). -C ICV Storage increment between vectors in C(). -C NCV Number of vectors in C() to be transformed. If NCV .LE. 0 -C no operations will be done on C(). -C -C***SEE ALSO DHFTI, DLSEI, DWNNLS -C***ROUTINES CALLED DAXPY, DDOT, DSWAP -C***REVISION HISTORY (YYMMDD) -C 790101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900911 Added DDOT to DOUBLE PRECISION statement. (WRB) -C***END PROLOGUE DH12 - - INTEGER I, I2, I3, I4, ICE, ICV, INCR, IUE, J, KL1, KL2, KLP, - * L1, L1M1, LPIVOT, M, MML1P2, MODE, NCV - DOUBLE PRECISION B, C, CL, CLINV, ONE, UL1M1, SM, U, UP, DDOT - DIMENSION U(IUE,*), C(*) -C BEGIN BLOCK PERMITTING ...EXITS TO 140 -C***FIRST EXECUTABLE STATEMENT DH12 - ONE = 1.0D0 -C -C ...EXIT - IF (0 .GE. LPIVOT .OR. LPIVOT .GE. L1 .OR. L1 .GT. M) GO TO 140 - CL = ABS(U(1,LPIVOT)) - IF (MODE .EQ. 2) GO TO 40 -C ****** CONSTRUCT THE TRANSFORMATION. ****** - DO 10 J = L1, M - CL = MAX(ABS(U(1,J)),CL) - 10 CONTINUE - IF (CL .GT. 0.0D0) GO TO 20 -C .........EXIT - GO TO 140 - 20 CONTINUE - CLINV = ONE/CL - SM = (U(1,LPIVOT)*CLINV)**2 - DO 30 J = L1, M - SM = SM + (U(1,J)*CLINV)**2 - 30 CONTINUE - CL = CL*SQRT(SM) - IF (U(1,LPIVOT) .GT. 0.0D0) CL = -CL - UP = U(1,LPIVOT) - CL - U(1,LPIVOT) = CL - GO TO 50 - 40 CONTINUE -C ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** -C - IF (CL .GT. 0.0D0) GO TO 50 -C ......EXIT - GO TO 140 - 50 CONTINUE -C ...EXIT - IF (NCV .LE. 0) GO TO 140 - B = UP*U(1,LPIVOT) -C B MUST BE NONPOSITIVE HERE. IF B = 0., RETURN. -C - IF (B .LT. 0.0D0) GO TO 60 -C ......EXIT - GO TO 140 - 60 CONTINUE - B = ONE/B - MML1P2 = M - L1 + 2 - IF (MML1P2 .LE. 20) GO TO 80 - L1M1 = L1 - 1 - KL1 = 1 + (L1M1 - 1)*ICE - KL2 = KL1 - KLP = 1 + (LPIVOT - 1)*ICE - UL1M1 = U(1,L1M1) - U(1,L1M1) = UP - IF (LPIVOT .NE. L1M1) CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) - DO 70 J = 1, NCV - SM = DDOT(MML1P2,U(1,L1M1),IUE,C(KL1),ICE) - SM = SM*B - CALL DAXPY(MML1P2,SM,U(1,L1M1),IUE,C(KL1),ICE) - KL1 = KL1 + ICV - 70 CONTINUE - U(1,L1M1) = UL1M1 -C ......EXIT - IF (LPIVOT .EQ. L1M1) GO TO 140 - KL1 = KL2 - CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) - GO TO 130 - 80 CONTINUE - I2 = 1 - ICV + ICE*(LPIVOT - 1) - INCR = ICE*(L1 - LPIVOT) - DO 120 J = 1, NCV - I2 = I2 + ICV - I3 = I2 + INCR - I4 = I3 - SM = C(I2)*UP - DO 90 I = L1, M - SM = SM + C(I3)*U(1,I) - I3 = I3 + ICE - 90 CONTINUE - IF (SM .EQ. 0.0D0) GO TO 110 - SM = SM*B - C(I2) = C(I2) + SM*UP - DO 100 I = L1, M - C(I4) = C(I4) + SM*U(1,I) - I4 = I4 + ICE - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - 130 CONTINUE - 140 CONTINUE - RETURN - END -*DECK DHFTI - SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, - + G, IP) -C***BEGIN PROLOGUE DHFTI -C***PURPOSE Solve a least squares problem for banded matrices using -C sequential accumulation of rows of the data matrix. -C Exactly one right-hand side vector is permitted. -C***LIBRARY SLATEC -C***CATEGORY D9 -C***TYPE DOUBLE PRECISION (HFTI-S, DHFTI-D) -C***KEYWORDS CURVE FITTING, LEAST SQUARES -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DIMENSION A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N) -C -C This subroutine solves a linear least squares problem or a set of -C linear least squares problems having the same matrix but different -C right-side vectors. The problem data consists of an M by N matrix -C A, an M by NB matrix B, and an absolute tolerance parameter TAU -C whose usage is described below. The NB column vectors of B -C represent right-side vectors for NB distinct linear least squares -C problems. -C -C This set of problems can also be written as the matrix least -C squares problem -C -C AX = B, -C -C where X is the N by NB solution matrix. -C -C Note that if B is the M by M identity matrix, then X will be the -C pseudo-inverse of A. -C -C This subroutine first transforms the augmented matrix (A B) to a -C matrix (R C) using premultiplying Householder transformations with -C column interchanges. All subdiagonal elements in the matrix R are -C zero and its diagonal elements satisfy -C -C ABS(R(I,I)).GE.ABS(R(I+1,I+1)), -C -C I = 1,...,L-1, where -C -C L = MIN(M,N). -C -C The subroutine will compute an integer, KRANK, equal to the number -C of diagonal terms of R that exceed TAU in magnitude. Then a -C solution of minimum Euclidean length is computed using the first -C KRANK rows of (R C). -C -C To be specific we suggest that the user consider an easily -C computable matrix norm, such as, the maximum of all column sums of -C magnitudes. -C -C Now if the relative uncertainty of B is EPS, (norm of uncertainty/ -C norm of B), it is suggested that TAU be set approximately equal to -C EPS*(norm of A). -C -C The user must dimension all arrays appearing in the call list.. -C A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N). This -C permits the solution of a range of problems in the same array -C space. -C -C The entire set of parameters for DHFTI are -C -C INPUT.. All TYPE REAL variables are DOUBLE PRECISION -C -C A(*,*),MDA,M,N The array A(*,*) initially contains the M by N -C matrix A of the least squares problem AX = B. -C The first dimensioning parameter of the array -C A(*,*) is MDA, which must satisfy MDA.GE.M -C Either M.GE.N or M.LT.N is permitted. There -C is no restriction on the rank of A. The -C condition MDA.LT.M is considered an error. -C -C B(*),MDB,NB If NB = 0 the subroutine will perform the -C orthogonal decomposition but will make no -C references to the array B(*). If NB.GT.0 -C the array B(*) must initially contain the M by -C NB matrix B of the least squares problem AX = -C B. If NB.GE.2 the array B(*) must be doubly -C subscripted with first dimensioning parameter -C MDB.GE.MAX(M,N). If NB = 1 the array B(*) may -C be either doubly or singly subscripted. In -C the latter case the value of MDB is arbitrary -C but it should be set to some valid integer -C value such as MDB = M. -C -C The condition of NB.GT.1.AND.MDB.LT. MAX(M,N) -C is considered an error. -C -C TAU Absolute tolerance parameter provided by user -C for pseudorank determination. -C -C H(*),G(*),IP(*) Arrays of working space used by DHFTI. -C -C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION -C -C A(*,*) The contents of the array A(*,*) will be -C modified by the subroutine. These contents -C are not generally required by the user. -C -C B(*) On return the array B(*) will contain the N by -C NB solution matrix X. -C -C KRANK Set by the subroutine to indicate the -C pseudorank of A. -C -C RNORM(*) On return, RNORM(J) will contain the Euclidean -C norm of the residual vector for the problem -C defined by the J-th column vector of the array -C B(*,*) for J = 1,...,NB. -C -C H(*),G(*) On return these arrays respectively contain -C elements of the pre- and post-multiplying -C Householder transformations used to compute -C the minimum Euclidean length solution. -C -C IP(*) Array in which the subroutine records indices -C describing the permutation of column vectors. -C The contents of arrays H(*),G(*) and IP(*) -C are not generally required by the user. -C -C***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares -C Problems, Prentice-Hall, Inc., 1974, Chapter 14. -C***ROUTINES CALLED D1MACH, DH12, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891006 Cosmetic changes to prologue. (WRB) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 901005 Replace usage of DDIFF with usage of D1MACH. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DHFTI - - INTEGER I, II, IOPT, IP(*), IP1, J, JB, JJ, K, KP1, KRANK, L, - * LDIAG, LMAX, M, MDA, MDB, N, NB, NERR - DOUBLE PRECISION A, B, D1MACH, DZERO, FACTOR, - * G, H, HMAX, RELEPS, RNORM, SM, SM1, SZERO, TAU, TMP - DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*) - SAVE RELEPS - DATA RELEPS /0.D0/ -C BEGIN BLOCK PERMITTING ...EXITS TO 360 -C***FIRST EXECUTABLE STATEMENT DHFTI - IF (RELEPS.EQ.0.D0) RELEPS = D1MACH(4) - SZERO = 0.0D0 - DZERO = 0.0D0 - FACTOR = 0.001D0 -C - K = 0 - LDIAG = MIN(M,N) - IF (LDIAG .LE. 0) GO TO 350 -C BEGIN BLOCK PERMITTING ...EXITS TO 130 -C BEGIN BLOCK PERMITTING ...EXITS TO 120 - IF (MDA .GE. M) GO TO 10 - NERR = 1 - IOPT = 2 -C CALL XERMSG ('SLATEC', 'DHFTI', -C + 'MDA.LT.M, PROBABLE ERROR.', -C + NERR, IOPT) -C ...............EXIT - GO TO 360 - 10 CONTINUE -C - IF (NB .LE. 1 .OR. MAX(M,N) .LE. MDB) GO TO 20 - NERR = 2 - IOPT = 2 -C CALL XERMSG ('SLATEC', 'DHFTI', -C + 'MDB.LT.MAX(M,N).AND.NB.GT.1. PROBABLE ERROR.', -C + NERR, IOPT) -C ...............EXIT - GO TO 360 - 20 CONTINUE -C - DO 100 J = 1, LDIAG -C BEGIN BLOCK PERMITTING ...EXITS TO 70 - IF (J .EQ. 1) GO TO 40 -C -C UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX -C .. - LMAX = J - DO 30 L = J, N - H(L) = H(L) - A(J-1,L)**2 - IF (H(L) .GT. H(LMAX)) LMAX = L - 30 CONTINUE -C ......EXIT - IF (FACTOR*H(LMAX) .GT. HMAX*RELEPS) GO TO 70 - 40 CONTINUE -C -C COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX -C .. - LMAX = J - DO 60 L = J, N - H(L) = 0.0D0 - DO 50 I = J, M - H(L) = H(L) + A(I,L)**2 - 50 CONTINUE - IF (H(L) .GT. H(LMAX)) LMAX = L - 60 CONTINUE - HMAX = H(LMAX) - 70 CONTINUE -C .. -C LMAX HAS BEEN DETERMINED -C -C DO COLUMN INTERCHANGES IF NEEDED. -C .. - IP(J) = LMAX - IF (IP(J) .EQ. J) GO TO 90 - DO 80 I = 1, M - TMP = A(I,J) - A(I,J) = A(I,LMAX) - A(I,LMAX) = TMP - 80 CONTINUE - H(LMAX) = H(J) - 90 CONTINUE -C -C COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A -C AND B. -C .. - CALL DH12(1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA, - * N-J) - CALL DH12(2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB) - 100 CONTINUE -C -C DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, -C TAU. -C .. - DO 110 J = 1, LDIAG -C ......EXIT - IF (ABS(A(J,J)) .LE. TAU) GO TO 120 - 110 CONTINUE - K = LDIAG -C ......EXIT - GO TO 130 - 120 CONTINUE - K = J - 1 - 130 CONTINUE - KP1 = K + 1 -C -C COMPUTE THE NORMS OF THE RESIDUAL VECTORS. -C - IF (NB .LT. 1) GO TO 170 - DO 160 JB = 1, NB - TMP = SZERO - IF (M .LT. KP1) GO TO 150 - DO 140 I = KP1, M - TMP = TMP + B(I,JB)**2 - 140 CONTINUE - 150 CONTINUE - RNORM(JB) = SQRT(TMP) - 160 CONTINUE - 170 CONTINUE -C SPECIAL FOR PSEUDORANK = 0 - IF (K .GT. 0) GO TO 210 - IF (NB .LT. 1) GO TO 200 - DO 190 JB = 1, NB - DO 180 I = 1, N - B(I,JB) = SZERO - 180 CONTINUE - 190 CONTINUE - 200 CONTINUE - GO TO 340 - 210 CONTINUE -C -C IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER -C DECOMPOSITION OF FIRST K ROWS. -C .. - IF (K .EQ. N) GO TO 230 - DO 220 II = 1, K - I = KP1 - II - CALL DH12(1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1) - 220 CONTINUE - 230 CONTINUE -C -C - IF (NB .LT. 1) GO TO 330 - DO 320 JB = 1, NB -C -C SOLVE THE K BY K TRIANGULAR SYSTEM. -C .. - DO 260 L = 1, K - SM = DZERO - I = KP1 - L - IP1 = I + 1 - IF (K .LT. IP1) GO TO 250 - DO 240 J = IP1, K - SM = SM + A(I,J)*B(J,JB) - 240 CONTINUE - 250 CONTINUE - SM1 = SM - B(I,JB) = (B(I,JB) - SM1)/A(I,I) - 260 CONTINUE -C -C COMPLETE COMPUTATION OF SOLUTION VECTOR. -C .. - IF (K .EQ. N) GO TO 290 - DO 270 J = KP1, N - B(J,JB) = SZERO - 270 CONTINUE - DO 280 I = 1, K - CALL DH12(2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1, - * MDB,1) - 280 CONTINUE - 290 CONTINUE -C -C RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE -C COLUMN INTERCHANGES. -C .. - DO 310 JJ = 1, LDIAG - J = LDIAG + 1 - JJ - IF (IP(J) .EQ. J) GO TO 300 - L = IP(J) - TMP = B(L,JB) - B(L,JB) = B(J,JB) - B(J,JB) = TMP - 300 CONTINUE - 310 CONTINUE - 320 CONTINUE - 330 CONTINUE - 340 CONTINUE - 350 CONTINUE -C .. -C THE SOLUTION VECTORS, X, ARE NOW -C IN THE FIRST N ROWS OF THE ARRAY B(,). -C - KRANK = K - 360 CONTINUE - RETURN - END -*DECK DLPDP - SUBROUTINE DLPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, - + IS) -C***BEGIN PROLOGUE DLPDP -C***SUBSIDIARY -C***PURPOSE Subsidiary to DLSEI -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (LPDP-S, DLPDP-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C **** Double Precision version of LPDP **** -C DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1), -C where N=N1+N2. This is a slight overestimate for WS(*). -C -C Determine an N1-vector W, and -C an N2-vector Z -C which minimizes the Euclidean length of W -C subject to G*W+H*Z .GE. Y. -C This is the least projected distance problem, LPDP. -C The matrices G and H are of respective -C dimensions M by N1 and M by N2. -C -C Called by subprogram DLSI( ). -C -C The matrix -C (G H Y) -C -C occupies rows 1,...,M and cols 1,...,N1+N2+1 of A(*,*). -C -C The solution (W) is returned in X(*). -C (Z) -C -C The value of MODE indicates the status of -C the computation after returning to the user. -C -C MODE=1 The solution was successfully obtained. -C -C MODE=2 The inequalities are inconsistent. -C -C***SEE ALSO DLSEI -C***ROUTINES CALLED DCOPY, DDOT, DNRM2, DSCAL, DWNNLS -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE DLPDP - -C - INTEGER I, IS(*), IW, IX, J, L, M, MDA, MODE, MODEW, N, N1, N2, - * NP1 - DOUBLE PRECISION A(MDA,*), DDOT, DNRM2, FAC, ONE, - * PRGOPT(*), RNORM, SC, WNORM, WS(*), X(*), YNORM, ZERO - SAVE ZERO, ONE, FAC - DATA ZERO,ONE /0.0D0,1.0D0/, FAC /0.1D0/ -C***FIRST EXECUTABLE STATEMENT DLPDP - N = N1 + N2 - MODE = 1 - IF (M .GT. 0) GO TO 20 - IF (N .LE. 0) GO TO 10 - X(1) = ZERO - CALL DCOPY(N,X,0,X,1) - 10 CONTINUE - WNORM = ZERO - GO TO 200 - 20 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 190 - NP1 = N + 1 -C -C SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE. - DO 40 I = 1, M - SC = DNRM2(N,A(I,1),MDA) - IF (SC .EQ. ZERO) GO TO 30 - SC = ONE/SC - CALL DSCAL(NP1,SC,A(I,1),MDA) - 30 CONTINUE - 40 CONTINUE -C -C SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO). - YNORM = DNRM2(M,A(1,NP1),1) - IF (YNORM .EQ. ZERO) GO TO 50 - SC = ONE/YNORM - CALL DSCAL(M,SC,A(1,NP1),1) - 50 CONTINUE -C -C SCALE COLS OF MATRIX H. - J = N1 + 1 - 60 IF (J .GT. N) GO TO 70 - SC = DNRM2(M,A(1,J),1) - IF (SC .NE. ZERO) SC = ONE/SC - CALL DSCAL(M,SC,A(1,J),1) - X(J) = SC - J = J + 1 - GO TO 60 - 70 CONTINUE - IF (N1 .LE. 0) GO TO 130 -C -C COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*). - IW = 0 - DO 80 I = 1, M -C -C MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY. - CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) - IW = IW + N2 -C -C MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY. - CALL DCOPY(N1,A(I,1),MDA,WS(IW+1),1) - IW = IW + N1 -C -C MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY. - WS(IW+1) = A(I,NP1) - IW = IW + 1 - 80 CONTINUE - WS(IW+1) = ZERO - CALL DCOPY(N,WS(IW+1),0,WS(IW+1),1) - IW = IW + N - WS(IW+1) = ONE - IW = IW + 1 -C -C SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0. THE -C MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR -C F = TRANSPOSE OF (0,...,0,1). - IX = IW + 1 - IW = IW + M -C -C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF -C DWNNLS( ). - IS(1) = 0 - IS(2) = 0 - CALL DWNNLS(WS,NP1,N2,NP1-N2,M,0,PRGOPT,WS(IX),RNORM, - * MODEW,IS,WS(IW+1)) -C -C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W. - SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) - IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) - * GO TO 110 - SC = ONE/SC - DO 90 J = 1, N1 - X(J) = SC*DDOT(M,A(1,J),1,WS(IX),1) - 90 CONTINUE -C -C COMPUTE THE VECTOR Q=Y-GW. OVERWRITE Y WITH THIS -C VECTOR. - DO 100 I = 1, M - A(I,NP1) = A(I,NP1) - DDOT(N1,A(I,1),MDA,X,1) - 100 CONTINUE - GO TO 120 - 110 CONTINUE - MODE = 2 -C .........EXIT - GO TO 190 - 120 CONTINUE - 130 CONTINUE - IF (N2 .LE. 0) GO TO 180 -C -C COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*). - IW = 0 - DO 140 I = 1, M - CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) - IW = IW + N2 - WS(IW+1) = A(I,NP1) - IW = IW + 1 - 140 CONTINUE - WS(IW+1) = ZERO - CALL DCOPY(N2,WS(IW+1),0,WS(IW+1),1) - IW = IW + N2 - WS(IW+1) = ONE - IW = IW + 1 - IX = IW + 1 - IW = IW + M -C -C SOLVE RV=S SUBJECT TO V.GE.0. THE MATRIX R =(TRANSPOSE -C OF (H Q)), WHERE Q=Y-GW. THE (N2+1)-VECTOR S =(TRANSPOSE -C OF (0,...,0,1)). -C -C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF -C DWNNLS( ). - IS(1) = 0 - IS(2) = 0 - CALL DWNNLS(WS,N2+1,0,N2+1,M,0,PRGOPT,WS(IX),RNORM,MODEW, - * IS,WS(IW+1)) -C -C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z. - SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) - IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) - * GO TO 160 - SC = ONE/SC - DO 150 J = 1, N2 - L = N1 + J - X(L) = SC*DDOT(M,A(1,L),1,WS(IX),1)*X(L) - 150 CONTINUE - GO TO 170 - 160 CONTINUE - MODE = 2 -C .........EXIT - GO TO 190 - 170 CONTINUE - 180 CONTINUE -C -C ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION. - CALL DSCAL(N,YNORM,X,1) - WNORM = DNRM2(N1,X,1) - 190 CONTINUE - 200 CONTINUE - RETURN - END -*DECK DWNNLS - SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, - + IWORK, WORK) -C***BEGIN PROLOGUE DWNNLS -C***PURPOSE Solve a linearly constrained least squares problem with -C equality constraints and nonnegativity constraints on -C selected variables. -C***LIBRARY SLATEC -C***CATEGORY K1A2A -C***TYPE DOUBLE PRECISION (WNNLS-S, DWNNLS-D) -C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, -C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, -C NONNEGATIVITY CONSTRAINTS, QUADRATIC PROGRAMMING -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Abstract -C -C This subprogram solves a linearly constrained least squares -C problem. Suppose there are given matrices E and A of -C respective dimensions ME by N and MA by N, and vectors F -C and B of respective lengths ME and MA. This subroutine -C solves the problem -C -C EX = F, (equations to be exactly satisfied) -C -C AX = B, (equations to be approximately satisfied, -C in the least squares sense) -C -C subject to components L+1,...,N nonnegative -C -C Any values ME.GE.0, MA.GE.0 and 0.LE. L .LE.N are permitted. -C -C The problem is reposed as problem DWNNLS -C -C (WT*E)X = (WT*F) -C ( A) ( B), (least squares) -C subject to components L+1,...,N nonnegative. -C -C The subprogram chooses the heavy weight (or penalty parameter) WT. -C -C The parameters for DWNNLS are -C -C INPUT.. All TYPE REAL variables are DOUBLE PRECISION -C -C W(*,*),MDW, The array W(*,*) is double subscripted with first -C ME,MA,N,L dimensioning parameter equal to MDW. For this -C discussion let us call M = ME + MA. Then MDW -C must satisfy MDW.GE.M. The condition MDW.LT.M -C is an error. -C -C The array W(*,*) contains the matrices and vectors -C -C (E F) -C (A B) -C -C in rows and columns 1,...,M and 1,...,N+1 -C respectively. Columns 1,...,L correspond to -C unconstrained variables X(1),...,X(L). The -C remaining variables are constrained to be -C nonnegative. The condition L.LT.0 or L.GT.N is -C an error. -C -C PRGOPT(*) This double precision array is the option vector. -C If the user is satisfied with the nominal -C subprogram features set -C -C PRGOPT(1)=1 (or PRGOPT(1)=1.0) -C -C Otherwise PRGOPT(*) is a linked list consisting of -C groups of data of the following form -C -C LINK -C KEY -C DATA SET -C -C The parameters LINK and KEY are each one word. -C The DATA SET can be comprised of several words. -C The number of items depends on the value of KEY. -C The value of LINK points to the first -C entry of the next group of data within -C PRGOPT(*). The exception is when there are -C no more options to change. In that -C case LINK=1 and the values KEY and DATA SET -C are not referenced. The general layout of -C PRGOPT(*) is as follows. -C -C ...PRGOPT(1)=LINK1 (link to first entry of next group) -C . PRGOPT(2)=KEY1 (key to the option change) -C . PRGOPT(3)=DATA VALUE (data value for this change) -C . . -C . . -C . . -C ...PRGOPT(LINK1)=LINK2 (link to the first entry of -C . next group) -C . PRGOPT(LINK1+1)=KEY2 (key to the option change) -C . PRGOPT(LINK1+2)=DATA VALUE -C ... . -C . . -C . . -C ...PRGOPT(LINK)=1 (no more options to change) -C -C Values of LINK that are nonpositive are errors. -C A value of LINK.GT.NLINK=100000 is also an error. -C This helps prevent using invalid but positive -C values of LINK that will probably extend -C beyond the program limits of PRGOPT(*). -C Unrecognized values of KEY are ignored. The -C order of the options is arbitrary and any number -C of options can be changed with the following -C restriction. To prevent cycling in the -C processing of the option array a count of the -C number of options changed is maintained. -C Whenever this count exceeds NOPT=1000 an error -C message is printed and the subprogram returns. -C -C OPTIONS.. -C -C KEY=6 -C Scale the nonzero columns of the -C entire data matrix -C (E) -C (A) -C to have length one. The DATA SET for -C this option is a single value. It must -C be nonzero if unit length column scaling is -C desired. -C -C KEY=7 -C Scale columns of the entire data matrix -C (E) -C (A) -C with a user-provided diagonal matrix. -C The DATA SET for this option consists -C of the N diagonal scaling factors, one for -C each matrix column. -C -C KEY=8 -C Change the rank determination tolerance from -C the nominal value of SQRT(SRELPR). This quantity -C can be no smaller than SRELPR, The arithmetic- -C storage precision. The quantity used -C here is internally restricted to be at -C least SRELPR. The DATA SET for this option -C is the new tolerance. -C -C KEY=9 -C Change the blow-up parameter from the -C nominal value of SQRT(SRELPR). The reciprocal of -C this parameter is used in rejecting solution -C components as too large when a variable is -C first brought into the active set. Too large -C means that the proposed component times the -C reciprocal of the parameter is not less than -C the ratio of the norms of the right-side -C vector and the data matrix. -C This parameter can be no smaller than SRELPR, -C the arithmetic-storage precision. -C -C For example, suppose we want to provide -C a diagonal matrix to scale the problem -C matrix and change the tolerance used for -C determining linear dependence of dropped col -C vectors. For these options the dimensions of -C PRGOPT(*) must be at least N+6. The FORTRAN -C statements defining these options would -C be as follows. -C -C PRGOPT(1)=N+3 (link to entry N+3 in PRGOPT(*)) -C PRGOPT(2)=7 (user-provided scaling key) -C -C CALL DCOPY(N,D,1,PRGOPT(3),1) (copy the N -C scaling factors from a user array called D(*) -C into PRGOPT(3)-PRGOPT(N+2)) -C -C PRGOPT(N+3)=N+6 (link to entry N+6 of PRGOPT(*)) -C PRGOPT(N+4)=8 (linear dependence tolerance key) -C PRGOPT(N+5)=... (new value of the tolerance) -C -C PRGOPT(N+6)=1 (no more options to change) -C -C -C IWORK(1), The amounts of working storage actually allocated -C IWORK(2) for the working arrays WORK(*) and IWORK(*), -C respectively. These quantities are compared with -C the actual amounts of storage needed for DWNNLS( ). -C Insufficient storage allocated for either WORK(*) -C or IWORK(*) is considered an error. This feature -C was included in DWNNLS( ) because miscalculating -C the storage formulas for WORK(*) and IWORK(*) -C might very well lead to subtle and hard-to-find -C execution errors. -C -C The length of WORK(*) must be at least -C -C LW = ME+MA+5*N -C This test will not be made if IWORK(1).LE.0. -C -C The length of IWORK(*) must be at least -C -C LIW = ME+MA+N -C This test will not be made if IWORK(2).LE.0. -C -C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION -C -C X(*) An array dimensioned at least N, which will -C contain the N components of the solution vector -C on output. -C -C RNORM The residual norm of the solution. The value of -C RNORM contains the residual vector length of the -C equality constraints and least squares equations. -C -C MODE The value of MODE indicates the success or failure -C of the subprogram. -C -C MODE = 0 Subprogram completed successfully. -C -C = 1 Max. number of iterations (equal to -C 3*(N-L)) exceeded. Nearly all problems -C should complete in fewer than this -C number of iterations. An approximate -C solution and its corresponding residual -C vector length are in X(*) and RNORM. -C -C = 2 Usage error occurred. The offending -C condition is noted with the error -C processing subprogram, XERMSG( ). -C -C User-designated -C Working arrays.. -C -C WORK(*) A double precision working array of length at least -C M + 5*N. -C -C IWORK(*) An integer-valued working array of length at least -C M+N. -C -C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Report SAND77-0552, Sandia -C Laboratories, June 1978. -C K. H. Haskell and R. J. Hanson, Selected algorithms for -C the linearly constrained least squares problem - a -C users guide, Report SAND78-1290, Sandia Laboratories, -C August 1979. -C K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Mathematical Programming -C 21 (1981), pp. 98-118. -C R. J. Hanson and K. H. Haskell, Two algorithms for the -C linearly constrained least squares problem, ACM -C Transactions on Mathematical Software, September 1982. -C C. L. Lawson and R. J. Hanson, Solving Least Squares -C Problems, Prentice-Hall, Inc., 1974. -C***ROUTINES CALLED DWNLSM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls, change Prologue -C comments to agree with WNNLS. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Removed prints and replaced DP --> DOUBLE PRECISION. (THC) -C***END PROLOGUE DWNNLS - - INTEGER IWORK(*), L, L1, L2, L3, L4, L5, LIW, LW, MA, MDW, ME, - * MODE, N - DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) -C CHARACTER*8 XERN1 -C***FIRST EXECUTABLE STATEMENT DWNNLS - MODE = 0 - IF (MA+ME.LE.0 .OR. N.LE.0) RETURN -C - IF (IWORK(1).GT.0) THEN - LW = ME + MA + 5*N - IF (IWORK(1).LT.LW) THEN -C WRITE (XERN1, '(I8)') LW -C CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // -C * 'ALLOCATED FOR WORK(*), NEED LW = ' // XERN1, 2, 1) - MODE = 2 - RETURN - ENDIF - ENDIF -C - IF (IWORK(2).GT.0) THEN - LIW = ME + MA + N - IF (IWORK(2).LT.LIW) THEN -C WRITE (XERN1, '(I8)') LIW -C CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // -C * 'ALLOCATED FOR IWORK(*), NEED LIW = ' // XERN1, 2, 1) - MODE = 2 - RETURN - ENDIF - ENDIF -C - IF (MDW.LT.ME+MA) THEN -C CALL XERMSG ('SLATEC', 'DWNNLS', -C * 'THE VALUE MDW.LT.ME+MA IS AN ERROR', 1, 1) - MODE = 2 - RETURN - ENDIF -C - IF (L.LT.0 .OR. L.GT.N) THEN -C CALL XERMSG ('SLATEC', 'DWNNLS', -C * 'L.GE.0 .AND. L.LE.N IS REQUIRED', 2, 1) - MODE = 2 - RETURN - ENDIF -C -C THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS -C WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS -C REQUIRED BY THE MAIN SUBROUTINE DWNLSM( ). -C - L1 = N + 1 - L2 = L1 + N - L3 = L2 + ME + MA - L4 = L3 + N - L5 = L4 + N -C - CALL DWNLSM(W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, IWORK, - * IWORK(L1), WORK(1), WORK(L1), WORK(L2), WORK(L3), - * WORK(L4), WORK(L5)) - RETURN - END -*DECK DWNLSM - SUBROUTINE DWNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, - + IPIVOT, ITYPE, WD, H, SCALE, Z, TEMP, D) -C***BEGIN PROLOGUE DWNLSM -C***SUBSIDIARY -C***PURPOSE Subsidiary to DWNNLS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLSM-S, DWNLSM-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to DWNNLS. -C The documentation for DWNNLS has complete usage instructions. -C -C In addition to the parameters discussed in the prologue to -C subroutine DWNNLS, the following work arrays are used in -C subroutine DWNLSM (they are passed through the calling -C sequence from DWNNLS for purposes of variable dimensioning). -C Their contents will in general be of no interest to the user. -C -C Variables of type REAL are DOUBLE PRECISION. -C -C IPIVOT(*) -C An array of length N. Upon completion it contains the -C pivoting information for the cols of W(*,*). -C -C ITYPE(*) -C An array of length M which is used to keep track -C of the classification of the equations. ITYPE(I)=0 -C denotes equation I as an equality constraint. -C ITYPE(I)=1 denotes equation I as a least squares -C equation. -C -C WD(*) -C An array of length N. Upon completion it contains the -C dual solution vector. -C -C H(*) -C An array of length N. Upon completion it contains the -C pivot scalars of the Householder transformations performed -C in the case KRANK.LT.L. -C -C SCALE(*) -C An array of length M which is used by the subroutine -C to store the diagonal matrix of weights. -C These are used to apply the modified Givens -C transformations. -C -C Z(*),TEMP(*) -C Working arrays of length N. -C -C D(*) -C An array of length N that contains the -C column scaling for the matrix (E). -C (A) -C -C***SEE ALSO DWNNLS -C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, -C SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, -C DWNLIT, IDAMAX, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Fixed an error message. (RWC) -C 900604 DP version created from SP version. (RWC) -C 900911 Restriction on value of ALAMDA included. (WRB) -C***END PROLOGUE DWNLSM - - INTEGER IPIVOT(*), ITYPE(*), L, MA, MDW, MME, MODE, N - DOUBLE PRECISION D(*), H(*), PRGOPT(*), RNORM, SCALE(*), TEMP(*), - * W(MDW,*), WD(*), X(*), Z(*) -C - EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, SLATEC_DROTM, - * SLATEC_DROTMG, DSCAL, DSWAP, DWNLIT, IDAMAX, XERMSG - DOUBLE PRECISION D1MACH, DASUM, DNRM2 - INTEGER IDAMAX -C - DOUBLE PRECISION ALAMDA, ALPHA, ALSQ, AMAX, BLOWUP, BNORM, - * DOPE(3), DRELPR, EANORM, FAC, SM, SPARAM(5), T, TAU, WMAX, Z2, - * ZZ - INTEGER I, IDOPE(3), IMAX, ISOL, ITEMP, ITER, ITMAX, IWMAX, J, - * JCON, JP, KEY, KRANK, L1, LAST, LINK, M, ME, NEXT, NIV, NLINK, - * NOPT, NSOLN, NTIMES - LOGICAL DONE, FEASBL, FIRST, HITCON, POS -C - SAVE DRELPR, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DWNLSM -C -C Initialize variables. -C DRELPR is the precision for the particular machine -C being used. This logic avoids resetting it every entry. -C - IF (FIRST) DRELPR = D1MACH(4) - FIRST = .FALSE. -C -C Set the nominal tolerance used in the code. -C - TAU = SQRT(DRELPR) -C - M = MA + MME - ME = MME - MODE = 2 -C -C To process option vector -C - FAC = 1.D-4 -C -C Set the nominal blow up factor used in the code. -C - BLOWUP = TAU -C -C The nominal column scaling used in the code is -C the identity scaling. -C - CALL DCOPY (N, 1.D0, 0, D, 1) -C -C Define bound for number of options to change. -C - NOPT = 1000 -C -C Define bound for positive value of LINK. -C - NLINK = 100000 - NTIMES = 0 - LAST = 1 - LINK = PRGOPT(1) - IF (LINK.LE.0 .OR. LINK.GT.NLINK) THEN -C CALL XERMSG ('SLATEC', 'DWNLSM', -C + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) - RETURN - ENDIF -C - 100 IF (LINK.GT.1) THEN - NTIMES = NTIMES + 1 - IF (NTIMES.GT.NOPT) THEN -C CALL XERMSG ('SLATEC', 'DWNLSM', -C + 'IN DWNNLS, THE LINKS IN THE OPTION VECTOR ARE CYCLING.', -C + 3, 1) - RETURN - ENDIF -C - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.6 .AND. PRGOPT(LAST+2).NE.0.D0) THEN - DO 110 J = 1,N - T = DNRM2(M,W(1,J),1) - IF (T.NE.0.D0) T = 1.D0/T - D(J) = T - 110 CONTINUE - ENDIF -C - IF (KEY.EQ.7) CALL DCOPY (N, PRGOPT(LAST+2), 1, D, 1) - IF (KEY.EQ.8) TAU = MAX(DRELPR,PRGOPT(LAST+2)) - IF (KEY.EQ.9) BLOWUP = MAX(DRELPR,PRGOPT(LAST+2)) -C - NEXT = PRGOPT(LINK) - IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN -C CALL XERMSG ('SLATEC', 'DWNLSM', -C + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) - RETURN - ENDIF -C - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C - DO 120 J = 1,N - CALL DSCAL (M, D(J), W(1,J), 1) - 120 CONTINUE -C -C Process option vector -C - DONE = .FALSE. - ITER = 0 - ITMAX = 3*(N-L) - MODE = 0 - NSOLN = L - L1 = MIN(M,L) -C -C Compute scale factor to apply to equality constraint equations. -C - DO 130 J = 1,N - WD(J) = DASUM(M,W(1,J),1) - 130 CONTINUE -C - IMAX = IDAMAX(N,WD,1) - EANORM = WD(IMAX) - BNORM = DASUM(M,W(1,N+1),1) - ALAMDA = EANORM/(DRELPR*FAC) -C -C On machines, such as the VAXes using D floating, with a very -C limited exponent range for double precision values, the previously -C computed value of ALAMDA may cause an overflow condition. -C Therefore, this code further limits the value of ALAMDA. -C - ALAMDA = MIN(ALAMDA,SQRT(D1MACH(2))) -C -C Define scaling diagonal matrix for modified Givens usage and -C classify equation types. -C - ALSQ = ALAMDA**2 - DO 140 I = 1,M -C -C When equation I is heavily weighted ITYPE(I)=0, -C else ITYPE(I)=1. -C - IF (I.LE.ME) THEN - T = ALSQ - ITEMP = 0 - ELSE - T = 1.D0 - ITEMP = 1 - ENDIF - SCALE(I) = T - ITYPE(I) = ITEMP - 140 CONTINUE -C -C Set the solution vector X(*) to zero and the column interchange -C matrix to the identity. -C - CALL DCOPY (N, 0.D0, 0, X, 1) - DO 150 I = 1,N - IPIVOT(I) = I - 150 CONTINUE -C -C Perform initial triangularization in the submatrix -C corresponding to the unconstrained variables. -C Set first L components of dual vector to zero because -C these correspond to the unconstrained variables. -C - CALL DCOPY (L, 0.D0, 0, WD, 1) -C -C The arrays IDOPE(*) and DOPE(*) are used to pass -C information to DWNLIT(). This was done to avoid -C a long calling sequence or the use of COMMON. -C - IDOPE(1) = ME - IDOPE(2) = NSOLN - IDOPE(3) = L1 -C - DOPE(1) = ALSQ - DOPE(2) = EANORM - DOPE(3) = TAU - CALL DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM, - + IDOPE, DOPE, DONE) - ME = IDOPE(1) - KRANK = IDOPE(2) - NIV = IDOPE(3) -C -C Perform WNNLS algorithm using the following steps. -C -C Until(DONE) -C compute search direction and feasible point -C when (HITCON) add constraints -C else perform multiplier test and drop a constraint -C fin -C Compute-Final-Solution -C -C To compute search direction and feasible point, -C solve the triangular system of currently non-active -C variables and store the solution in Z(*). -C -C To solve system -C Copy right hand side into TEMP vector to use overwriting method. -C - 160 IF (DONE) GO TO 330 - ISOL = L + 1 - IF (NSOLN.GE.ISOL) THEN - CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) - DO 170 J = NSOLN,ISOL,-1 - IF (J.GT.KRANK) THEN - I = NIV - NSOLN + J - ELSE - I = J - ENDIF -C - IF (J.GT.KRANK .AND. J.LE.L) THEN - Z(J) = 0.D0 - ELSE - Z(J) = TEMP(I)/W(I,J) - CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) - ENDIF - 170 CONTINUE - ENDIF -C -C Increment iteration counter and check against maximum number -C of iterations. -C - ITER = ITER + 1 - IF (ITER.GT.ITMAX) THEN - MODE = 1 - DONE = .TRUE. - ENDIF -C -C Check to see if any constraints have become active. -C If so, calculate an interpolation factor so that all -C active constraints are removed from the basis. -C - ALPHA = 2.D0 - HITCON = .FALSE. - DO 180 J = L+1,NSOLN - ZZ = Z(J) - IF (ZZ.LE.0.D0) THEN - T = X(J)/(X(J)-ZZ) - IF (T.LT.ALPHA) THEN - ALPHA = T - JCON = J - ENDIF - HITCON = .TRUE. - ENDIF - 180 CONTINUE -C -C Compute search direction and feasible point -C - IF (HITCON) THEN -C -C To add constraints, use computed ALPHA to interpolate between -C last feasible solution X(*) and current unconstrained (and -C infeasible) solution Z(*). -C - DO 190 J = L+1,NSOLN - X(J) = X(J) + ALPHA*(Z(J)-X(J)) - 190 CONTINUE - FEASBL = .FALSE. -C -C Remove column JCON and shift columns JCON+1 through N to the -C left. Swap column JCON into the N th position. This achieves -C upper Hessenberg form for the nonactive constraints and -C leaves an upper Hessenberg matrix to retriangularize. -C - 200 DO 210 I = 1,M - T = W(I,JCON) - CALL DCOPY (N-JCON, W(I, JCON+1), MDW, W(I, JCON), MDW) - W(I,N) = T - 210 CONTINUE -C -C Update permuted index vector to reflect this shift and swap. -C - ITEMP = IPIVOT(JCON) - DO 220 I = JCON,N - 1 - IPIVOT(I) = IPIVOT(I+1) - 220 CONTINUE - IPIVOT(N) = ITEMP -C -C Similarly permute X(*) vector. -C - CALL DCOPY (N-JCON, X(JCON+1), 1, X(JCON), 1) - X(N) = 0.D0 - NSOLN = NSOLN - 1 - NIV = NIV - 1 -C -C Retriangularize upper Hessenberg matrix after adding -C constraints. -C - I = KRANK + JCON - L - DO 230 J = JCON,NSOLN - IF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.0) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), - + MDW, SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.1) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), - + MDW, SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.0) THEN - CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) - CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) - ITEMP = ITYPE(I+1) - ITYPE(I+1) = ITYPE(I) - ITYPE(I) = ITEMP -C -C Swapped row was formerly a pivot element, so it will -C be large enough to perform elimination. -C Zero IP1 to I in column J. -C - IF (W(I+1,J).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), - + MDW, SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.1) THEN - IF (SCALE(I)*W(I,J)**2/ALSQ.GT.(TAU*EANORM)**2) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, - + W(I+1,J+1), MDW, SPARAM) - ENDIF - ELSE - CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) - CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) - ITEMP = ITYPE(I+1) - ITYPE(I+1) = ITYPE(I) - ITYPE(I) = ITEMP - W(I+1,J) = 0.D0 - ENDIF - ENDIF - I = I + 1 - 230 CONTINUE -C -C See if the remaining coefficients in the solution set are -C feasible. They should be because of the way ALPHA was -C determined. If any are infeasible, it is due to roundoff -C error. Any that are non-positive will be set to zero and -C removed from the solution set. -C - DO 240 JCON = L+1,NSOLN - IF (X(JCON).LE.0.D0) GO TO 250 - 240 CONTINUE - FEASBL = .TRUE. - 250 IF (.NOT.FEASBL) GO TO 200 - ELSE -C -C To perform multiplier test and drop a constraint. -C - CALL DCOPY (NSOLN, Z, 1, X, 1) - IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) -C -C Reclassify least squares equations as equalities as necessary. -C - I = NIV + 1 - 260 IF (I.LE.ME) THEN - IF (ITYPE(I).EQ.0) THEN - I = I + 1 - ELSE - CALL DSWAP (N+1, W(I,1), MDW, W(ME,1), MDW) - CALL DSWAP (1, SCALE(I), 1, SCALE(ME), 1) - ITEMP = ITYPE(I) - ITYPE(I) = ITYPE(ME) - ITYPE(ME) = ITEMP - ME = ME - 1 - ENDIF - GO TO 260 - ENDIF -C -C Form inner product vector WD(*) of dual coefficients. -C - DO 280 J = NSOLN+1,N - SM = 0.D0 - DO 270 I = NSOLN+1,M - SM = SM + SCALE(I)*W(I,J)*W(I,N+1) - 270 CONTINUE - WD(J) = SM - 280 CONTINUE -C -C Find J such that WD(J)=WMAX is maximum. This determines -C that the incoming column J will reduce the residual vector -C and be positive. -C - 290 WMAX = 0.D0 - IWMAX = NSOLN + 1 - DO 300 J = NSOLN+1,N - IF (WD(J).GT.WMAX) THEN - WMAX = WD(J) - IWMAX = J - ENDIF - 300 CONTINUE - IF (WMAX.LE.0.D0) GO TO 330 -C -C Set dual coefficients to zero for incoming column. -C - WD(IWMAX) = 0.D0 -C -C WMAX .GT. 0.D0, so okay to move column IWMAX to solution set. -C Perform transformation to retriangularize, and test for near -C linear dependence. -C -C Swap column IWMAX into NSOLN-th position to maintain upper -C Hessenberg form of adjacent columns, and add new column to -C triangular decomposition. -C - NSOLN = NSOLN + 1 - NIV = NIV + 1 - IF (NSOLN.NE.IWMAX) THEN - CALL DSWAP (M, W(1,NSOLN), 1, W(1,IWMAX), 1) - WD(IWMAX) = WD(NSOLN) - WD(NSOLN) = 0.D0 - ITEMP = IPIVOT(NSOLN) - IPIVOT(NSOLN) = IPIVOT(IWMAX) - IPIVOT(IWMAX) = ITEMP - ENDIF -C -C Reduce column NSOLN so that the matrix of nonactive constraints -C variables is triangular. -C - DO 320 J = M,NIV+1,-1 - JP = J - 1 -C -C When operating near the ME line, test to see if the pivot -C element is near zero. If so, use the largest element above -C it as the pivot. This is to maintain the sharp interface -C between weighted and non-weighted rows in all cases. -C - IF (J.EQ.ME+1) THEN - IMAX = ME - AMAX = SCALE(ME)*W(ME,NSOLN)**2 - DO 310 JP = J - 1,NIV,-1 - T = SCALE(JP)*W(JP,NSOLN)**2 - IF (T.GT.AMAX) THEN - IMAX = JP - AMAX = T - ENDIF - 310 CONTINUE - JP = IMAX - ENDIF -C - IF (W(J,NSOLN).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(JP), SCALE(J), W(JP,NSOLN), - + W(J,NSOLN), SPARAM) - W(J,NSOLN) = 0.D0 - CALL SLATEC_DROTM (N+1-NSOLN, W(JP,NSOLN+1), MDW, - + W(J,NSOLN+1), MDW, SPARAM) - ENDIF - 320 CONTINUE -C -C Solve for Z(NSOLN)=proposed new value for X(NSOLN). Test if -C this is nonpositive or too large. If this was true or if the -C pivot term was zero, reject the column as dependent. -C - IF (W(NIV,NSOLN).NE.0.D0) THEN - ISOL = NIV - Z2 = W(ISOL,N+1)/W(ISOL,NSOLN) - Z(NSOLN) = Z2 - POS = Z2 .GT. 0.D0 - IF (Z2*EANORM.GE.BNORM .AND. POS) THEN - POS = .NOT. (BLOWUP*Z2*EANORM.GE.BNORM) - ENDIF -C -C Try to add row ME+1 as an additional equality constraint. -C Check size of proposed new solution component. -C Reject it if it is too large. -C - ELSEIF (NIV.LE.ME .AND. W(ME+1,NSOLN).NE.0.D0) THEN - ISOL = ME + 1 - IF (POS) THEN -C -C Swap rows ME+1 and NIV, and scale factors for these rows. -C - CALL DSWAP (N+1, W(ME+1,1), MDW, W(NIV,1), MDW) - CALL DSWAP (1, SCALE(ME+1), 1, SCALE(NIV), 1) - ITEMP = ITYPE(ME+1) - ITYPE(ME+1) = ITYPE(NIV) - ITYPE(NIV) = ITEMP - ME = ME + 1 - ENDIF - ELSE - POS = .FALSE. - ENDIF -C - IF (.NOT.POS) THEN - NSOLN = NSOLN - 1 - NIV = NIV - 1 - ENDIF - IF (.NOT.(POS.OR.DONE)) GO TO 290 - ENDIF - GO TO 160 -C -C Else perform multiplier test and drop a constraint. To compute -C final solution. Solve system, store results in X(*). -C -C Copy right hand side into TEMP vector to use overwriting method. -C - 330 ISOL = 1 - IF (NSOLN.GE.ISOL) THEN - CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) - DO 340 J = NSOLN,ISOL,-1 - IF (J.GT.KRANK) THEN - I = NIV - NSOLN + J - ELSE - I = J - ENDIF -C - IF (J.GT.KRANK .AND. J.LE.L) THEN - Z(J) = 0.D0 - ELSE - Z(J) = TEMP(I)/W(I,J) - CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) - ENDIF - 340 CONTINUE - ENDIF -C -C Solve system. -C - CALL DCOPY (NSOLN, Z, 1, X, 1) -C -C Apply Householder transformations to X(*) if KRANK.LT.L -C - IF (KRANK.LT.L) THEN - DO 350 I = 1,KRANK - CALL DH12 (2, I, KRANK+1, L, W(I,1), MDW, H(I), X, 1, 1, 1) - 350 CONTINUE - ENDIF -C -C Fill in trailing zeroes for constrained variables not in solution. -C - IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) -C -C Permute solution vector to natural order. -C - DO 380 I = 1,N - J = I - 360 IF (IPIVOT(J).EQ.I) GO TO 370 - J = J + 1 - GO TO 360 -C - 370 IPIVOT(J) = IPIVOT(I) - IPIVOT(I) = J - CALL DSWAP (1, X(J), 1, X(I), 1) - 380 CONTINUE -C -C Rescale the solution using the column scaling. -C - DO 390 J = 1,N - X(J) = X(J)*D(J) - 390 CONTINUE -C - DO 400 I = NSOLN+1,M - T = W(I,N+1) - IF (I.LE.ME) T = T/ALAMDA - T = (SCALE(I)*T)*T - RNORM = RNORM + T - 400 CONTINUE -C - RNORM = SQRT(RNORM) - RETURN - END -*DECK DROTM - SUBROUTINE SLATEC_DROTM (N, DX, INCX, DY, INCY, DPARAM) -C***BEGIN PROLOGUE SLATEC_DROTM -C***PURPOSE Apply a modified Givens transformation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A8 -C***TYPE DOUBLE PRECISION (SROTM-S, DROTM-D) -C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C Kincaid, D. R., (U. of Texas) -C Krogh, F. T., (JPL) -C***DESCRIPTION -C -C B L A S Subprogram -C Description of Parameters -C -C --Input-- -C N number of elements in input vector(s) -C DX double precision vector with N elements -C INCX storage spacing between elements of DX -C DY double precision vector with N elements -C INCY storage spacing between elements of DY -C DPARAM 5-element D.P. vector. DPARAM(1) is DFLAG described below. -C Locations 2-5 of SPARAM contain elements of the -C transformation matrix H described below. -C -C --Output-- -C DX rotated vector (unchanged if N .LE. 0) -C DY rotated vector (unchanged if N .LE. 0) -C -C Apply the modified Givens transformation, H, to the 2 by N matrix -C (DX**T) -C (DY**T) , where **T indicates transpose. The elements of DX are -C in DX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else -C LX = 1+(1-N)*INCX, and similarly for DY using LY and INCY. -C -C With DPARAM(1)=DFLAG, H has one of the following forms: -C -C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 -C -C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) -C H=( ) ( ) ( ) ( ) -C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). -C -C See SLATEC_DROTMG for a description of data storage in DPARAM. -C -C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. -C Krogh, Basic linear algebra subprograms for Fortran -C usage, Algorithm No. 539, Transactions on Mathematical -C Software 5, 3 (September 1979), pp. 308-323. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920310 Corrected definition of LX in DESCRIPTION. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Renamed SLATEC_DROTM to avoid BLAS naming conflict. (THC) -C***END PROLOGUE SLATEC_DROTM - - DOUBLE PRECISION DFLAG, DH12, DH22, DX, TWO, Z, DH11, DH21, - 1 DPARAM, DY, W, ZERO - DIMENSION DX(*), DY(*), DPARAM(5) - SAVE ZERO, TWO - DATA ZERO, TWO /0.0D0, 2.0D0/ -C***FIRST EXECUTABLE STATEMENT SLATEC_DROTM - DFLAG=DPARAM(1) - IF (N.LE.0 .OR. (DFLAG+TWO.EQ.ZERO)) GO TO 140 - IF (.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 -C - NSTEPS=N*INCX -C IF (DFLAG) 50, 10, 30 -C Replaced obsolete code above with an IF-block (THC). - IF (DFLAG < 0) THEN - GO TO 50 - ELSE IF (DFLAG == 0) THEN - GO TO 10 - ELSE IF (DFLAG > 0) THEN - GO TO 30 - END IF - 10 CONTINUE - DH12=DPARAM(4) - DH21=DPARAM(3) - DO 20 I = 1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W+Z*DH12 - DY(I)=W*DH21+Z - 20 CONTINUE - GO TO 140 - 30 CONTINUE - DH11=DPARAM(2) - DH22=DPARAM(5) - DO 40 I = 1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W*DH11+Z - DY(I)=-W+DH22*Z - 40 CONTINUE - GO TO 140 - 50 CONTINUE - DH11=DPARAM(2) - DH12=DPARAM(4) - DH21=DPARAM(3) - DH22=DPARAM(5) - DO 60 I = 1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W*DH11+Z*DH12 - DY(I)=W*DH21+Z*DH22 - 60 CONTINUE - GO TO 140 - 70 CONTINUE - KX=1 - KY=1 - IF (INCX .LT. 0) KX = 1+(1-N)*INCX - IF (INCY .LT. 0) KY = 1+(1-N)*INCY -C -C IF (DFLAG) 120,80,100 -C Replaced obsolete code above with an IF-block (THC). - IF (DFLAG < 0) THEN - GO TO 120 - ELSE IF (DFLAG == 0) THEN - GO TO 80 - ELSE IF (DFLAG > 0) THEN - GO TO 100 - END IF - 80 CONTINUE - DH12=DPARAM(4) - DH21=DPARAM(3) - DO 90 I = 1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W+Z*DH12 - DY(KY)=W*DH21+Z - KX=KX+INCX - KY=KY+INCY - 90 CONTINUE - GO TO 140 - 100 CONTINUE - DH11=DPARAM(2) - DH22=DPARAM(5) - DO 110 I = 1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W*DH11+Z - DY(KY)=-W+DH22*Z - KX=KX+INCX - KY=KY+INCY - 110 CONTINUE - GO TO 140 - 120 CONTINUE - DH11=DPARAM(2) - DH12=DPARAM(4) - DH21=DPARAM(3) - DH22=DPARAM(5) - DO 130 I = 1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W*DH11+Z*DH12 - DY(KY)=W*DH21+Z*DH22 - KX=KX+INCX - KY=KY+INCY - 130 CONTINUE - 140 CONTINUE - RETURN - END -*DECK SLATEC_DROTMG - SUBROUTINE SLATEC_DROTMG (DD1, DD2, DX1, DY1, DPARAM) -C***BEGIN PROLOGUE SLATEC_DROTMG -C***PURPOSE Construct a modified Givens transformation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B10 -C***TYPE DOUBLE PRECISION (SROTMG-S, DROTMG-D) -C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C Kincaid, D. R., (U. of Texas) -C Krogh, F. T., (JPL) -C***DESCRIPTION -C -C B L A S Subprogram -C Description of Parameters -C -C --Input-- -C DD1 double precision scalar -C DD2 double precision scalar -C DX1 double precision scalar -C DX2 double precision scalar -C DPARAM D.P. 5-vector. DPARAM(1)=DFLAG defined below. -C Locations 2-5 contain the rotation matrix. -C -C --Output-- -C DD1 changed to represent the effect of the transformation -C DD2 changed to represent the effect of the transformation -C DX1 changed to represent the effect of the transformation -C DX2 unchanged -C -C Construct the modified Givens transformation matrix H which zeros -C the second component of the 2-vector (SQRT(DD1)*DX1,SQRT(DD2)* -C DY2)**T. -C With DPARAM(1)=DFLAG, H has one of the following forms: -C -C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 -C -C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) -C H=( ) ( ) ( ) ( ) -C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). -C -C Locations 2-5 of DPARAM contain DH11, DH21, DH12, and DH22, -C respectively. (Values of 1.D0, -1.D0, or 0.D0 implied by the -C value of DPARAM(1) are not stored in DPARAM.) -C -C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. -C Krogh, Basic linear algebra subprograms for Fortran -C usage, Algorithm No. 539, Transactions on Mathematical -C Software 5, 3 (September 1979), pp. 308-323. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920316 Prologue corrected. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Renamed SLATEC_DROTMG to avoid BLAS naming conflict. (THC) -C***END PROLOGUE SLATEC_DROTMG - - DOUBLE PRECISION GAM, ONE, RGAMSQ, DD1, DD2, DH11, DH12, DH21, - 1 DH22, DPARAM, DP1, DP2, DQ1, DQ2, DU, DY1, ZERO, - 2 GAMSQ, DFLAG, DTEMP, DX1, TWO - DIMENSION DPARAM(5) - SAVE ZERO, ONE, TWO, GAM, GAMSQ, RGAMSQ - DATA ZERO, ONE, TWO /0.0D0, 1.0D0, 2.0D0/ - DATA GAM, GAMSQ, RGAMSQ /4096.0D0, 16777216.D0, 5.9604645D-8/ -C***FIRST EXECUTABLE STATEMENT SLATEC_DROTMG - IF (.NOT. DD1 .LT. ZERO) GO TO 10 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 10 CONTINUE -C CASE-DD1-NONNEGATIVE - DP2=DD2*DY1 - IF (.NOT. DP2 .EQ. ZERO) GO TO 20 - DFLAG=-TWO - GO TO 260 -C REGULAR-CASE.. - 20 CONTINUE - DP1=DD1*DX1 - DQ2=DP2*DY1 - DQ1=DP1*DX1 -C - IF (.NOT. ABS(DQ1) .GT. ABS(DQ2)) GO TO 40 - DH21=-DY1/DX1 - DH12=DP2/DP1 -C - DU=ONE-DH12*DH21 -C - IF (.NOT. DU .LE. ZERO) GO TO 30 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 30 CONTINUE - DFLAG=ZERO - DD1=DD1/DU - DD2=DD2/DU - DX1=DX1*DU -C GO SCALE-CHECK.. - GO TO 100 - 40 CONTINUE - IF (.NOT. DQ2 .LT. ZERO) GO TO 50 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 50 CONTINUE - DFLAG=ONE - DH11=DP1/DP2 - DH22=DX1/DY1 - DU=ONE+DH11*DH22 - DTEMP=DD2/DU - DD2=DD1/DU - DD1=DTEMP - DX1=DY1*DU -C GO SCALE-CHECK - GO TO 100 -C PROCEDURE..ZERO-H-D-AND-DX1.. - 60 CONTINUE - DFLAG=-ONE - DH11=ZERO - DH12=ZERO - DH21=ZERO - DH22=ZERO -C - DD1=ZERO - DD2=ZERO - DX1=ZERO -C RETURN.. - GO TO 220 -C PROCEDURE..FIX-H.. - 70 CONTINUE - IF (.NOT. DFLAG .GE. ZERO) GO TO 90 -C - IF (.NOT. DFLAG .EQ. ZERO) GO TO 80 - DH11=ONE - DH22=ONE - DFLAG=-ONE - GO TO 90 - 80 CONTINUE - DH21=-ONE - DH12=ONE - DFLAG=-ONE - 90 CONTINUE -C GO TO IGO,(120,150,180,210) -C Replaced the above obsolete code with modern alternative (THC). - SELECT CASE(IGO) - CASE(120) - GO TO 120 - CASE(150) - GO TO 150 - CASE(180) - GO TO 180 - CASE(210) - GO TO 210 - END SELECT -C PROCEDURE..SCALE-CHECK - 100 CONTINUE - 110 CONTINUE - IF (.NOT. DD1 .LE. RGAMSQ) GO TO 130 - IF (DD1 .EQ. ZERO) GO TO 160 - IGO = 120 -C FIX-H.. - GO TO 70 - 120 CONTINUE - DD1=DD1*GAM**2 - DX1=DX1/GAM - DH11=DH11/GAM - DH12=DH12/GAM - GO TO 110 - 130 CONTINUE - 140 CONTINUE - IF (.NOT. DD1 .GE. GAMSQ) GO TO 160 - IGO = 150 -C FIX-H.. - GO TO 70 - 150 CONTINUE - DD1=DD1/GAM**2 - DX1=DX1*GAM - DH11=DH11*GAM - DH12=DH12*GAM - GO TO 140 - 160 CONTINUE - 170 CONTINUE - IF (.NOT. ABS(DD2) .LE. RGAMSQ) GO TO 190 - IF (DD2 .EQ. ZERO) GO TO 220 - IGO = 180 -C FIX-H.. - GO TO 70 - 180 CONTINUE - DD2=DD2*GAM**2 - DH21=DH21/GAM - DH22=DH22/GAM - GO TO 170 - 190 CONTINUE - 200 CONTINUE - IF (.NOT. ABS(DD2) .GE. GAMSQ) GO TO 220 - IGO = 210 -C FIX-H.. - GO TO 70 - 210 CONTINUE - DD2=DD2/GAM**2 - DH21=DH21*GAM - DH22=DH22*GAM - GO TO 200 - 220 CONTINUE -C IF (DFLAG) 250,230,240 -C Replaced obsolete code above with an IF-block (THC). - IF (DFLAG < 0) THEN - GO TO 250 - ELSE IF (DFLAG == 0) THEN - GO TO 230 - ELSE IF (DFLAG > 0) THEN - GO TO 240 - END IF - - 230 CONTINUE - DPARAM(3)=DH21 - DPARAM(4)=DH12 - GO TO 260 - 240 CONTINUE - DPARAM(2)=DH11 - DPARAM(5)=DH22 - GO TO 260 - 250 CONTINUE - DPARAM(2)=DH11 - DPARAM(3)=DH21 - DPARAM(4)=DH12 - DPARAM(5)=DH22 - 260 CONTINUE - DPARAM(1)=DFLAG - RETURN - END -*DECK DWNLIT - SUBROUTINE DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, - + RNORM, IDOPE, DOPE, DONE) -C***BEGIN PROLOGUE DWNLIT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DWNNLS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLIT-S, DWNLIT-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to DWNNLS( ). -C The documentation for DWNNLS( ) has complete usage instructions. -C -C Note The M by (N+1) matrix W( , ) contains the rt. hand side -C B as the (N+1)st col. -C -C Triangularize L1 by L1 subsystem, where L1=MIN(M,L), with -C col interchanges. -C -C***SEE ALSO DWNNLS -C***ROUTINES CALLED DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, -C DSWAP, DWNLT1, DWNLT2, DWNLT3, IDAMAX -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -C 890620 Revised to make WNLT1, WNLT2, and WNLT3 subroutines. (RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900604 DP version created from SP version. . (RWC) -C***END PROLOGUE DWNLIT - - INTEGER IDOPE(*), IPIVOT(*), ITYPE(*), L, M, MDW, N - DOUBLE PRECISION DOPE(*), H(*), RNORM, SCALE(*), W(MDW,*) - LOGICAL DONE -C - EXTERNAL DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, - * DWNLT1, DWNLT2, DWNLT3, IDAMAX - INTEGER IDAMAX - LOGICAL DWNLT2 -C - DOUBLE PRECISION ALSQ, AMAX, EANORM, FACTOR, HBAR, RN, SPARAM(5), - * T, TAU - INTEGER I, I1, IMAX, IR, J, J1, JJ, JP, KRANK, L1, LB, LEND, ME, - * MEND, NIV, NSOLN - LOGICAL INDEP, RECALC -C -C***FIRST EXECUTABLE STATEMENT DWNLIT - ME = IDOPE(1) - NSOLN = IDOPE(2) - L1 = IDOPE(3) -C - ALSQ = DOPE(1) - EANORM = DOPE(2) - TAU = DOPE(3) -C - LB = MIN(M-1,L) - RECALC = .TRUE. - RNORM = 0.D0 - KRANK = 0 -C -C We set FACTOR=1.0 so that the heavy weight ALAMDA will be -C included in the test for column independence. -C - FACTOR = 1.D0 - LEND = L - DO 180 I=1,LB -C -C Set IR to point to the I-th row. -C - IR = I - MEND = M - CALL DWNLT1 (I, LEND, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, - + W) -C -C Update column SS and find pivot column. -C - CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange. -C Test independence of incoming column. -C - 130 IF (DWNLT2(ME, MEND, IR, FACTOR, TAU, SCALE, W(1,I))) THEN -C -C Eliminate I-th column below diagonal using modified Givens -C transformations applied to (A B). -C -C When operating near the ME line, use the largest element -C above it as the pivot. -C - DO 160 J=M,I+1,-1 - JP = J-1 - IF (J.EQ.ME+1) THEN - IMAX = ME - AMAX = SCALE(ME)*W(ME,I)**2 - DO 150 JP=J-1,I,-1 - T = SCALE(JP)*W(JP,I)**2 - IF (T.GT.AMAX) THEN - IMAX = JP - AMAX = T - ENDIF - 150 CONTINUE - JP = IMAX - ENDIF -C - IF (W(J,I).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(JP), SCALE(J), W(JP,I), - + W(J,I), SPARAM) - W(J,I) = 0.D0 - CALL SLATEC_DROTM (N+1-I, W(JP,I+1), MDW, W(J,I+1), - + MDW, SPARAM) - ENDIF - 160 CONTINUE - ELSE IF (LEND.GT.I) THEN -C -C Column I is dependent. Swap with column LEND. -C Perform column interchange, -C and find column in remaining set with largest SS. -C - CALL DWNLT3 (I, LEND, M, MDW, IPIVOT, H, W) - LEND = LEND - 1 - IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 - HBAR = H(IMAX) - GO TO 130 - ELSE - KRANK = I - 1 - GO TO 190 - ENDIF - 180 CONTINUE - KRANK = L1 -C - 190 IF (KRANK.LT.ME) THEN - FACTOR = ALSQ - DO 200 I=KRANK+1,ME - CALL DCOPY (L, 0.D0, 0, W(I,1), MDW) - 200 CONTINUE -C -C Determine the rank of the remaining equality constraint -C equations by eliminating within the block of constrained -C variables. Remove any redundant constraints. -C - RECALC = .TRUE. - LB = MIN(L+ME-KRANK, N) - DO 270 I=L+1,LB - IR = KRANK + I - L - LEND = N - MEND = ME - CALL DWNLT1 (I, LEND, ME, IR, MDW, RECALC, IMAX, HBAR, H, - + SCALE, W) -C -C Update col ss and find pivot col -C - CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange -C Eliminate elements in the I-th col. -C - DO 240 J=ME,IR+1,-1 - IF (W(J,I).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), - + W(J,I), SPARAM) - W(J,I) = 0.D0 - CALL SLATEC_DROTM (N+1-I, W(J-1,I+1), MDW,W(J,I+1), - + MDW, SPARAM) - ENDIF - 240 CONTINUE -C -C I=column being eliminated. -C Test independence of incoming column. -C Remove any redundant or dependent equality constraints. -C - IF (.NOT.DWNLT2(ME, MEND, IR, FACTOR,TAU,SCALE,W(1,I))) THEN - JJ = IR - DO 260 IR=JJ,ME - CALL DCOPY (N, 0.D0, 0, W(IR,1), MDW) - RNORM = RNORM + (SCALE(IR)*W(IR,N+1)/ALSQ)*W(IR,N+1) - W(IR,N+1) = 0.D0 - SCALE(IR) = 1.D0 -C -C Reclassify the zeroed row as a least squares equation. -C - ITYPE(IR) = 1 - 260 CONTINUE -C -C Reduce ME to reflect any discovered dependent equality -C constraints. -C - ME = JJ - 1 - GO TO 280 - ENDIF - 270 CONTINUE - ENDIF -C -C Try to determine the variables KRANK+1 through L1 from the -C least squares equations. Continue the triangularization with -C pivot element W(ME+1,I). -C - 280 IF (KRANK.LT.L1) THEN - RECALC = .TRUE. -C -C Set FACTOR=ALSQ to remove effect of heavy weight from -C test for column independence. -C - FACTOR = ALSQ - DO 350 I=KRANK+1,L1 -C -C Set IR to point to the ME+1-st row. -C - IR = ME+1 - LEND = L - MEND = M - CALL DWNLT1 (I, L, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, - + W) -C -C Update column SS and find pivot column. -C - CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange. -C Eliminate I-th column below the IR-th element. -C - DO 320 J=M,IR+1,-1 - IF (W(J,I).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), - + W(J,I), SPARAM) - W(J,I) = 0.D0 - CALL SLATEC_DROTM (N+1-I, W(J-1,I+1), MDW, W(J,I+1), - + MDW, SPARAM) - ENDIF - 320 CONTINUE -C -C Test if new pivot element is near zero. -C If so, the column is dependent. -C Then check row norm test to be classified as independent. -C - T = SCALE(IR)*W(IR,I)**2 - INDEP = T .GT. (TAU*EANORM)**2 - IF (INDEP) THEN - RN = 0.D0 - DO 340 I1=IR,M - DO 330 J1=I+1,N - RN = MAX(RN, SCALE(I1)*W(I1,J1)**2) - 330 CONTINUE - 340 CONTINUE - INDEP = T .GT. RN*TAU**2 - ENDIF -C -C If independent, swap the IR-th and KRANK+1-th rows to -C maintain the triangular form. Update the rank indicator -C KRANK and the equality constraint pointer ME. -C - IF (.NOT.INDEP) GO TO 360 - CALL DSWAP(N+1, W(KRANK+1,1), MDW, W(IR,1), MDW) - CALL DSWAP(1, SCALE(KRANK+1), 1, SCALE(IR), 1) -C -C Reclassify the least square equation as an equality -C constraint and rescale it. -C - ITYPE(IR) = 0 - T = SQRT(SCALE(KRANK+1)) - CALL DSCAL(N+1, T, W(KRANK+1,1), MDW) - SCALE(KRANK+1) = ALSQ - ME = ME+1 - KRANK = KRANK+1 - 350 CONTINUE - ENDIF -C -C If pseudorank is less than L, apply Householder transformation. -C from right. -C - 360 IF (KRANK.LT.L) THEN - DO 370 J=KRANK,1,-1 - CALL DH12 (1, J, KRANK+1, L, W(J,1), MDW, H(J), W, MDW, 1, - + J-1) - 370 CONTINUE - ENDIF -C - NIV = KRANK + NSOLN - L - IF (L.EQ.N) DONE = .TRUE. -C -C End of initial triangularization. -C - IDOPE(1) = ME - IDOPE(2) = KRANK - IDOPE(3) = NIV - RETURN - END -*DECK DWNLT1 - SUBROUTINE DWNLT1 (I, LEND, MEND, IR, MDW, RECALC, IMAX, HBAR, H, - + SCALE, W) -C***BEGIN PROLOGUE DWNLT1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLT1-S, DWNLT1-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C To update the column Sum Of Squares and find the pivot column. -C The column Sum of Squares Vector will be updated at each step. -C When numerically necessary, these values will be recomputed. -C -C***SEE ALSO DWNLIT -C***ROUTINES CALLED IDAMAX -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DWNLT1 - - INTEGER I, IMAX, IR, LEND, MDW, MEND - DOUBLE PRECISION H(*), HBAR, SCALE(*), W(MDW,*) - LOGICAL RECALC -C - EXTERNAL IDAMAX - INTEGER IDAMAX -C - INTEGER J, K -C -C***FIRST EXECUTABLE STATEMENT DWNLT1 - IF (IR.NE.1 .AND. (.NOT.RECALC)) THEN -C -C Update column SS=sum of squares. -C - DO 10 J=I,LEND - H(J) = H(J) - SCALE(IR-1)*W(IR-1,J)**2 - 10 CONTINUE -C -C Test for numerical accuracy. -C - IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 - RECALC = (HBAR+1.E-3*H(IMAX)) .EQ. HBAR - ENDIF -C -C If required, recalculate column SS, using rows IR through MEND. -C - IF (RECALC) THEN - DO 30 J=I,LEND - H(J) = 0.D0 - DO 20 K=IR,MEND - H(J) = H(J) + SCALE(K)*W(K,J)**2 - 20 CONTINUE - 30 CONTINUE -C -C Find column with largest SS. -C - IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 - HBAR = H(IMAX) - ENDIF - RETURN - END -*DECK DWNLT2 - LOGICAL FUNCTION DWNLT2 (ME, MEND, IR, FACTOR, TAU, SCALE, WIC) -C***BEGIN PROLOGUE DWNLT2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLT2-S, DWNLT2-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C To test independence of incoming column. -C -C Test the column IC to determine if it is linearly independent -C of the columns already in the basis. In the initial tri. step, -C we usually want the heavy weight ALAMDA to be included in the -C test for independence. In this case, the value of FACTOR will -C have been set to 1.E0 before this procedure is invoked. -C In the potentially rank deficient problem, the value of FACTOR -C will have been set to ALSQ=ALAMDA**2 to remove the effect of the -C heavy weight from the test for independence. -C -C Write new column as partitioned vector -C (A1) number of components in solution so far = NIV -C (A2) M-NIV components -C And compute SN = inverse weighted length of A1 -C RN = inverse weighted length of A2 -C Call the column independent when RN .GT. TAU*SN -C -C***SEE ALSO DWNLIT -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DWNLT2 - - DOUBLE PRECISION FACTOR, SCALE(*), TAU, WIC(*) - INTEGER IR, ME, MEND -C - DOUBLE PRECISION RN, SN, T - INTEGER J -C -C***FIRST EXECUTABLE STATEMENT DWNLT2 - SN = 0.E0 - RN = 0.E0 - DO 10 J=1,MEND - T = SCALE(J) - IF (J.LE.ME) T = T/FACTOR - T = T*WIC(J)**2 -C - IF (J.LT.IR) THEN - SN = SN + T - ELSE - RN = RN + T - ENDIF - 10 CONTINUE - DWNLT2 = RN .GT. SN*TAU**2 - RETURN - END -*DECK DWNLT3 - SUBROUTINE DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C***BEGIN PROLOGUE DWNLT3 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLT3-S, DWNLT3-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Perform column interchange. -C Exchange elements of permuted index vector and perform column -C interchanges. -C -C***SEE ALSO DWNLIT -C***ROUTINES CALLED DSWAP -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DWNLT3 - - INTEGER I, IMAX, IPIVOT(*), M, MDW - DOUBLE PRECISION H(*), W(MDW,*) -C - EXTERNAL DSWAP -C - DOUBLE PRECISION T - INTEGER ITEMP -C -C***FIRST EXECUTABLE STATEMENT DWNLT3 - IF (IMAX.NE.I) THEN - ITEMP = IPIVOT(I) - IPIVOT(I) = IPIVOT(IMAX) - IPIVOT(IMAX) = ITEMP -C - CALL DSWAP(M, W(1,IMAX), 1, W(1,I), 1) -C - T = H(IMAX) - H(IMAX) = H(I) - H(I) = T - ENDIF - RETURN - END diff --git a/test/test_bin.sh b/test/test_bin.sh deleted file mode 100755 index 4ad2f50..0000000 --- a/test/test_bin.sh +++ /dev/null @@ -1,46 +0,0 @@ -#!/bin/bash - -# Run delsparses on 2d/4d VarSys test problems and analyze output -bin/delsparses data/varsys/sample_input2d.dat > sample_out2d.txt -if [[ `wc -l < sample_out2d.txt` == 710 ]] -then - echo The command-line executables seem to be installed correctly. - rm sample_out2d.txt -else - echo There seems to be an issue with the CL install of delaunaysparses. - echo See sample_out2d.txt for more information... - exit 1 -fi -bin/delsparses data/varsys/sample_input4d.dat > sample_out4d.txt -if [[ `wc -l < sample_out4d.txt` == 3027 ]] -then - echo The command-line executables seem to be installed correctly. - rm sample_out4d.txt -else - echo There seems to be an issue with the CL install of delaunaysparses. - echo See sample_out4d.txt for more information... - exit 1 -fi - -# Run delsparsep on 2d/4d VarSys test problems and analyze output -export OMP_NUM_THREADS=2 -bin/delsparsep data/varsys/sample_input2d.dat > sample_out2d.txt -if [[ `wc -l < sample_out2d.txt` == 710 ]] -then - echo The command-line executables seem to be installed correctly. - rm sample_out2d.txt -else - echo There seems to be an issue with the CL install of delaunaysparsep. - echo See sample_out2d.txt for more information... - exit 1 -fi -bin/delsparsep data/varsys/sample_input4d.dat > sample_out4d.txt -if [[ `wc -l < sample_out4d.txt` == 3027 ]] -then - echo The command-line executables seem to be installed correctly. - rm sample_out4d.txt -else - echo There seems to be an issue with the CL install of delaunaysparsep. - echo See sample_out4d.txt for more information... - exit 1 -fi diff --git a/test/test_c_install.c b/test/test_c_install.c deleted file mode 100644 index 24ee528..0000000 --- a/test/test_c_install.c +++ /dev/null @@ -1,149 +0,0 @@ -#include -#include -#include -#include "delsparse.h" - -int main() { - // Set the problem dimensions - int n = 50, d = 5, m = 10, ir = 2; - - // Generate random data in the unit cube - double data[n*d]; - for (int i = 0; i < n*d; i++) - data[i] = rand(); - - // Generate interpolation points - double interp[m*d]; - for (int i = 0; i < m*d; i++) - interp[i] = 0.25 + 0.5 * rand(); - - // Generate response values - double interp_in[n*ir]; - for (int i = 0; i < n*ir; i++) - interp_in[i] = rand(); - - // Allocate the output arrays - int simps[m*(d+1)], ierr[m]; - double weights[m*(d+1)], interp_out[m*ir], rnorm[m]; - - // Set the optional input parameters - bool chain = false, exact = true; - int ibudget = 10000, pmode = 1; - double eps = 0.00000001, extrap = 0.1; - - // Call the serial C interface with no options - c_delaunaysparses(&d, &n, data, &m, interp, simps, weights, ierr); - - // Check for errors - for (int i = 0; i < m; i++) { - if (ierr[i] > 2) { - printf("Error %i occurred while testing c_delaunaysparses" - " with no optional arguments\n\n", - ierr[i]); - return -1; - } - } - - // Call the serial C interface and compute interpolant values - c_delaunaysparses_interp(&d, &n, data, &m, interp, simps, weights, ierr, - &ir, interp_in, interp_out); - - // Check for errors - for (int i = 0; i < m; i++) { - if (ierr[i] > 2) { - printf("Error %i occurred while testing c_delaunaysparses" - " and computing interpolant values\n\n", ierr[i]); - return -1; - } - } - - // Call the serial C interface with optional inputs - c_delaunaysparses_opts(&d, &n, data, &m, interp, simps, weights, ierr, - &eps, &extrap, rnorm, &ibudget, &chain, &exact); - - // Check for errors - for (int i = 0; i < m; i++) { - if (ierr[i] > 2) { - printf("Error %i occurred while testing c_delaunaysparses" - " with optional arguments\n\n", ierr[i]); - return -1; - } - } - - // Call the serial C interface with optional inputs and interpolation - c_delaunaysparses_interp_opts(&d, &n, data, &m, interp, simps, weights, - ierr, &ir, interp_in, interp_out, &eps, - &extrap, rnorm, &ibudget, &chain, &exact); - - // Check for errors - for (int i = 0; i < m; i++) { - if (ierr[i] > 2) { - printf("Error %i occurred while testing c_delaunaysparses" - " with optional arguments and computing the interpolant\n\n", - ierr[i]); - return -1; - } - } - - - // Call the parallel C interface with no options - c_delaunaysparsep(&d, &n, data, &m, interp, simps, weights, ierr); - - // Check for errors - for (int i = 0; i < m; i++) { - if (ierr[i] > 2) { - printf("Error %i occurred while testing c_delaunaysparsep" - " with no optional arguments\n\n", - ierr[i]); - return -1; - } - } - - // Call the parallel C interface and compute interpolant values - c_delaunaysparsep_interp(&d, &n, data, &m, interp, simps, weights, ierr, - &ir, interp_in, interp_out); - - // Check for errors - for (int i = 0; i < m; i++) { - if (ierr[i] > 2) { - printf("Error %i occurred while testing c_delaunaysparsep" - " and computing interpolant values\n\n", ierr[i]); - return -1; - } - } - - // Call the parallel C interface with optional inputs - c_delaunaysparsep_opts(&d, &n, data, &m, interp, simps, weights, ierr, - &eps, &extrap, rnorm, &ibudget, &chain, &exact, - &pmode); - - // Check for errors - for (int i = 0; i < m; i++) { - if (ierr[i] > 2) { - printf("Error %i occurred while testing c_delaunaysparsep" - " with optional arguments\n\n", ierr[i]); - return -1; - } - } - - // Call the parallel C interface with optional inputs and interpolation - c_delaunaysparsep_interp_opts(&d, &n, data, &m, interp, simps, weights, - ierr, &ir, interp_in, interp_out, &eps, - &extrap, rnorm, &ibudget, &chain, &exact, - &pmode); - - // Check for errors - for (int i = 0; i < m; i++) { - if (ierr[i] > 2) { - printf("Error %i occurred while testing c_delaunaysparsep" - " with optional arguments and computing the interpolant\n\n", - ierr[i]); - return -1; - } - } - - - // If we made it this far, the build was successful - printf("The C binding installation appears to be successful.\n\n"); - return 0; -} diff --git a/test/test_install.f90 b/test/test_install.f90 deleted file mode 100644 index 8868896..0000000 --- a/test/test_install.f90 +++ /dev/null @@ -1,153 +0,0 @@ -PROGRAM TEST_INSTALL -! Driver code that tests the installation of DELAUNAYSPARSES and -! DELAUNAYSPARSEP. To do so, a toy interpolation problem is -! computed and the results are compared to the known solution. - -! Last Update: February, 2019 -! Primary Author: Tyler Chang -USE DELSPARSE_MOD -USE OMP_LIB -IMPLICIT NONE - -! Declare data. -INTEGER :: SIMPS(3,6), IERR(6) -REAL(KIND=R8) :: EPS -REAL(KIND=R8) :: INTERP_IN(1,20), INTERP_OUT(1,6), EXPECTED_OUT(1,6), & - & PTS(2,20), PTS_TMP(2,20), Q(2,6), Q_TMP(2,6), WEIGHTS(3,6) - -EPS = SQRT(EPSILON(0.0_R8)) -PTS = TRANSPOSE( RESHAPE( (/ & - 0.10877683233208346_R8, & - 0.65747571677546268_R8, & - 0.74853271200744009_R8, & - 0.25853058969031051_R8, & - 0.38508322804628770_R8, & - 0.19855613243388937_R8, & - 0.88590610193360986_R8, & - 0.73957680789581970_R8, & - 0.46130107231752082_R8, & - 0.61044888569019906_R8, & - 0.88848755836796889_R8, & - 0.56504950910258156_R8, & - 0.63374920061262452_R8, & - 0.47642100637444385_R8, & - 0.89167673297718886_R8, & - 0.85575976312324076_R8, & - 0.36741400280848768_R8, & - 0.22540743314109113_R8, & - 0.57887702455276135_R8, & - 0.33794226559725304_R8, & - 0.76211800269757757_R8, & - 0.082963515866522064_R8, & - 0.016220459783666152_R8, & - 0.17155847087049503_R8, & - 0.12930597950925682_R8, & - 0.91552991190955113_R8, & - 0.30469899967300274_R8, & - 0.064234640774060825_R8, & - 0.67129213095523377_R8, & - 0.56860397761470494_R8, & - 0.10547481357911370_R8, & - 0.59408216854500884_R8, & - 0.90989152079869851_R8, & - 0.91232248805035077_R8, & - 0.13873375923421827_R8, & - 0.68652421762380056_R8, & - 0.53775708104383380_R8, & - 0.63512621583969442_R8, & - 0.98798019619988187_R8, & - 0.87480704030477330_R8 /), & - (/ 20, 2 /) ) ) -Q = TRANSPOSE( RESHAPE( (/ & - 0.500000000000000000_R8, & - 0.250000000000000000_R8, & - 0.250000000000000000_R8, & - 0.750000000000000000_R8, & - 0.750000000000000000_R8, & - 0.100000000000000000_R8, & - 0.500000000000000000_R8, & - 0.250000000000000000_R8, & - 0.750000000000000000_R8, & - 0.250000000000000000_R8, & - 0.750000000000000000_R8, & - 0.500000000000000000_R8 /), & - (/6, 2/) ) ) -INTERP_IN = RESHAPE( (/ & - 0.87089483502966103_R8, & - 0.74043923264198475_R8, & - 0.76475317179110625_R8, & - 0.43008906056080554_R8, & - 0.51438920755554451_R8, & - 1.1140860443434404_R8, & - 1.1906051016066126_R8, & - 0.80381144866988052_R8, & - 1.1325932032727546_R8, & - 1.1790528633049040_R8, & - 0.99396237194708259_R8, & - 1.1591316776475904_R8, & - 1.5436407214113230_R8, & - 1.3887434944247947_R8, & - 1.0304104922114070_R8, & - 1.5422839807470412_R8, & - 0.90517108385232148_R8, & - 0.86053364898078555_R8, & - 1.5668572207526432_R8, & - 1.2127493059020265_R8 /), & - (/ 1, 20 /) ) -EXPECTED_OUT = RESHAPE( (/ & - 1.00000000000000000_R8, & - 0.50000000000000000_R8, & - 1.00000000000000000_R8, & - 1.00000000000000000_R8, & - 1.50000000000000000_R8, & - 0.68862615900613189_R8 /), & - (/ 1, 6/) ) - -! Test DELAUNAYSPARSES. -PTS_TMP = PTS; Q_TMP = Q -CALL DELAUNAYSPARSES(2, 20, PTS_TMP, 6, Q_TMP, SIMPS, WEIGHTS, IERR, & - & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT) -IF(ANY(ABS(INTERP_OUT - EXPECTED_OUT) > EPS)) THEN - WRITE(*,*) "DELAUNAYSPARSES produced an incorrect result. ", & - & " The installation is not correct." - STOP -END IF - -! Test DELAUNAYSPARSEP, PMODE=1. -PTS_TMP = PTS; Q_TMP = Q -CALL OMP_SET_NUM_THREADS(4) -CALL DELAUNAYSPARSEP(2, 20, PTS_TMP, 6, Q_TMP, SIMPS, WEIGHTS, IERR, & - & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT, PMODE=1) -IF(ANY(ABS(INTERP_OUT - EXPECTED_OUT) > EPS)) THEN - WRITE(*,*) "DELAUNAYSPARSEP produced an incorrect result. ", & - & " The installation is not correct." - STOP -END IF - -! Test DELAUNAYSPARSEP, PMODE=2. -PTS_TMP = PTS; Q_TMP = Q -CALL OMP_SET_NUM_THREADS(4) -CALL DELAUNAYSPARSEP(2, 20, PTS_TMP, 6, Q_TMP, SIMPS, WEIGHTS, IERR, & - & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT, PMODE=2) -IF(ANY(ABS(INTERP_OUT - EXPECTED_OUT) > EPS)) THEN - WRITE(*,*) "DELAUNAYSPARSEP produced an incorrect result. ", & - & " The installation is not correct." - STOP -END IF - -! Test DELAUNAYSPARSEP, PMODE=3. -CALL OMP_SET_NESTED(.TRUE.) -CALL OMP_SET_NUM_THREADS(2) -PTS_TMP = PTS; Q_TMP = Q -CALL DELAUNAYSPARSEP(2, 20, PTS_TMP, 6, Q_TMP, SIMPS, WEIGHTS, IERR, & - & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT, PMODE=3) -IF(ANY(ABS(INTERP_OUT - EXPECTED_OUT) > EPS)) THEN - WRITE(*,*) "DELAUNAYSPARSEP produced an incorrect result. ", & - & " The installation is not correct." - STOP -END IF - -! If all the tests passed, then the installation is correct. -WRITE(*,*) "The installation of DELAUNAYSPARSE appears correct." - -END PROGRAM TEST_INSTALL diff --git a/toms1012/LICENSE b/toms1012/LICENSE deleted file mode 100644 index 00ce8f0..0000000 --- a/toms1012/LICENSE +++ /dev/null @@ -1,22 +0,0 @@ -MIT License - -Copyright (c) 2020 Tyler H. Chang, Layne T. Watson, Thomas C. H. Lux, -Ali R. Butt, Kirk W. Cameron, and Yili Hong. - -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, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -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. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. diff --git a/toms1012/Makefile b/toms1012/Makefile deleted file mode 100644 index 7e67fe1..0000000 --- a/toms1012/Makefile +++ /dev/null @@ -1,31 +0,0 @@ -FORT = gfortran -CFLAGS = -c -OPTS = -fopenmp -LEGACY = -std=legacy - -all: samples samplep test_install - ./test_install - -test_install: test_install.f90 delsparse.o slatec.o lapack.o blas.o - $(FORT) $(OPTS) test_install.f90 delsparse.o slatec.o lapack.o blas.o -o test_install - -samples: samples.f90 delsparse.o slatec.o lapack.o blas.o - $(FORT) $(OPTS) samples.f90 delsparse.o slatec.o lapack.o blas.o -o samples - -samplep: samplep.f90 delsparse.o slatec.o lapack.o blas.o - $(FORT) $(OPTS) samplep.f90 delsparse.o slatec.o lapack.o blas.o -o samplep - -delsparse.o: delsparse.f90 - $(FORT) $(CFLAGS) $(OPTS) delsparse.f90 -o delsparse.o - -slatec.o : slatec.f - $(FORT) $(CFLAGS) $(OPTS) $(LEGACY) slatec.f -o slatec.o - -lapack.o : lapack.f - $(FORT) $(CFLAGS) $(OPTS) lapack.f -o lapack.o - -blas.o : blas.f - $(FORT) $(CFLAGS) $(OPTS) blas.f -o blas.o - -clean: - rm -f *.o *.mod samples samplep test_install diff --git a/toms1012/README b/toms1012/README deleted file mode 100644 index 779ca5a..0000000 --- a/toms1012/README +++ /dev/null @@ -1,83 +0,0 @@ - ACM TOMS Algorithm 1012: DELAUNAYSPARSE - -- Interpolation via a Sparse Subset of the Delaunay Triangulation - -The package DELAUNAYSPARSE contains serial and parallel codes, written -in FORTRAN 2003 with OpenMP, for performing interpolation in medium to -high dimensions via a sparse subset of the Delaunay triangulation. The -serial driver subroutine is DELAUNAYSPARSES and the parallel driver is -DELAUNAYSPARSEP. Both subroutines use the REAL_PRECISION module from -HOMPACK90 (ACM TOMS Algorithm 777) for approximately 64-bit precision -on all known machines, and the SLATEC subroutine DWNNLS (ACM TOMS -Algorithm 587) for solving an inequality constrained least squares -problem. Additionally, DELAUNAYSPARSE depends on several BLAS and LAPACK -subroutines. The module DELSPARSE_MOD contains the REAL_PRECISION (R8) -data type, and interface blocks for DELAUNAYSPARSES, DELAUNAYSPARSEP, -and DWNNLS. Comments at the top of each subroutine document their -usage, and examples demonstrating their usage are provided in the -sample programs samples.f90 and samplep.f90. - -The physical organization is as follows: - - * The file delsparse.f90 contains the module REAL_PRECISION, - DELSPARSE_MOD, and the driver subroutines DELAUNAYSPARSES, and - DELAUNAYSPARSEP. - * The file slatec.f contains the subroutine DWNNLS and its dependencies - from the SLATEC library. This library has been slightly modified to - comply with the modern Fortran standards. Additionally, legacy - implementations of the BLAS subroutines DROTM and DTROMG have been - included under different names to avoid dependency issues. - * The file samples.f90 contains a sample main program demonstrating the - usage of DELAUNAYSPARSES, with optional arguments. - * The file samplep.f90 contains a sample main program demonstrating the - usage of DELAUNAYSPARSEP, with optional arguments. - * The file test_install.f90 contains a simple test program that checks - whether the installation of DELAUNAYSPARSE appears correct, based - on the output to a small interpolation/extrapolation problem. - * The file sample_input2d.dat contains a sample 2-dimensional input - data set for samples.f90 and samplep.f90. - * The file sample_input4d.dat contains a sample 4-dimensional input - data set for samples.f90 and samplep.f90. - * The files lapack.f and blas.f contain all LAPACK and BLAS - subroutines that are referenced (both directly and indirectly) in - DELAUNAYSPARSE. - * A sample GNU Makefile is provided. - -From here on, the files samples.f90 and samplep.f90 will be referred -to collectively as sample{s|p}.f90 and the files sample_input2d.dat -and sample_input4d.dat will be referred to collectively as -sample_input{2|4}d.dat. - -To check that the installation of DELAUNAYSPARSES and DELAUNAYSPARSEP is -correct, assuming that your Fortran compiler allows mixing fixed format -.f and free format .f90 files in the same compile command, use the command - -$FORT $OPTS delsparse.f90 slatec.f lapack.f blas.f test_install.f90 \ - -o test_install $LIBS - -where '$FORT' is a Fortran 2003 compliant compiler supporting OpenMP -4.5, '$OPTS' is a list of compiler options, and '$LIBS' is a list of -flags to link the BLAS and LAPACK libraries, if those exist on your -system (in which case the files blas.f and lapack.f can be omitted -from the compile command). To run the parallel code, $OPTS must -include the compiler option for OpenMP. - -Then run the tests using - -./test_install - -To compile and link the sample main programs sample{s|p}.f90, use - -$FORT $OPTS delsparse.f90 slatec.f lapack.f blas.f sample{s|p}.f90 \ - -o sample{s|p} $LIBS - -similar to above. To run a sample main program, use - -./sample{s|p} sample_input{2|4}d.dat - -where 'sample_input{2|4}d.dat' could be replaced by any other similarly -formatted data file. - ---------------------------------------------------------------------------- - -For further inquiries, contact -Tyler Chang, tchang@anl.gov. diff --git a/toms1012/blas.f b/toms1012/blas.f deleted file mode 100644 index df991ff..0000000 --- a/toms1012/blas.f +++ /dev/null @@ -1,2206 +0,0 @@ - -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* ====================================== - - DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* Purpose: -* ============= -* -* DASUM takes the sum of the absolute values. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 3/93 to return if incx .le. 0. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,M,MP1,NINCX -* .. -* .. Intrinsic Functions .. - INTRINSIC DABS,MOD -* .. - DASUM = 0.0D0 - DTEMP = 0.0D0 - IF (N.LE.0 .OR. INCX.LE.0) RETURN - IF (INCX.EQ.1) THEN -* code for increment equal to 1 -* -* -* clean-up loop -* - M = MOD(N,6) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DTEMP + DABS(DX(I)) - END DO - IF (N.LT.6) THEN - DASUM = DTEMP - RETURN - END IF - END IF - MP1 = M + 1 - DO I = MP1,N,6 - DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) + - $ DABS(DX(I+2)) + DABS(DX(I+3)) + - $ DABS(DX(I+4)) + DABS(DX(I+5)) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - DTEMP = DTEMP + DABS(DX(I)) - END DO - END IF - DASUM = DTEMP - RETURN - END - - SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - DOUBLE PRECISION DA - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* Purpose: -* ============= -* -* DAXPY constant times a vector plus a vector. -* uses unrolled loops for increments equal to one. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DA is DOUBLE PRECISION. On entry, DA specifies the scalar alpha. -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -* -* INCY is INTEGER storage spacing between elements of DY -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (DA.EQ.0.0D0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,4) - IF (M.NE.0) THEN - DO I = 1,M - DY(I) = DY(I) + DA*DX(I) - END DO - END IF - IF (N.LT.4) RETURN - MP1 = M + 1 - DO I = MP1,N,4 - DY(I) = DY(I) + DA*DX(I) - DY(I+1) = DY(I+1) + DA*DX(I+1) - DY(I+2) = DY(I+2) + DA*DX(I+2) - DY(I+3) = DY(I+3) + DA*DX(I+3) - END DO - ELSE -* -* code for unequal increments or equal increments -* 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 I = 1,N - DY(IY) = DY(IY) + DA*DX(IX) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN - END - - SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* Purpose: -* ============= -* -* DCOPY copies a vector, x, to a vector, y. -* uses unrolled loops for increments equal to 1. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -* -* INCY is INTEGER storage spacing between elements of DY -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,7) - IF (M.NE.0) THEN - DO I = 1,M - DY(I) = DX(I) - END DO - IF (N.LT.7) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,7 - DY(I) = DX(I) - DY(I+1) = DX(I+1) - DY(I+2) = DX(I+2) - DY(I+3) = DX(I+3) - DY(I+4) = DX(I+4) - DY(I+5) = DX(I+5) - DY(I+6) = DX(I+6) - END DO - ELSE -* -* code for unequal increments or equal increments -* 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 I = 1,N - DY(IY) = DX(IX) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN - END - - DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* Purpose: -* ============= -* -* DDOT forms the dot product of two vectors. -* uses unrolled loops for increments equal to one. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -* -* INCY is INTEGER storage spacing between elements of DY -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - DDOT = 0.0D0 - DTEMP = 0.0D0 - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,5) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DTEMP + DX(I)*DY(I) - END DO - IF (N.LT.5) THEN - DDOT=DTEMP - RETURN - END IF - END IF - MP1 = M + 1 - DO I = MP1,N,5 - DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) + - $ DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) - END DO - ELSE -* -* code for unequal increments or equal increments -* 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 I = 1,N - DTEMP = DTEMP + DX(IX)*DY(IY) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - DDOT = DTEMP - RETURN - END - - SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* -- Reference BLAS level3 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of -* Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER K,LDA,LDB,LDC,M,N - CHARACTER TRANSA,TRANSB -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB - LOGICAL NOTA,NOTB -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Set NOTA and NOTB as true if A and B respectively are -* not -* transposed and set NROWA, NCOLA and NROWB as the number of -* rows -* and columns of A and the number of rows of B -* respectively. -* - NOTA = LSAME(TRANSA,'N') - NOTB = LSAME(TRANSB,'N') - IF (NOTA) THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - END IF - IF (NOTB) THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. - + (.NOT.LSAME(TRANSA,'T'))) THEN - INFO = 1 - ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. - + (.NOT.LSAME(TRANSB,'T'))) THEN - INFO = 2 - ELSE IF (M.LT.0) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (K.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 8 - ELSE IF (LDB.LT.MAX(1,NROWB)) THEN - INFO = 10 - ELSE IF (LDC.LT.MAX(1,M)) THEN - INFO = 13 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGEMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN -* -* And if alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,M - C(I,J) = BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF (NOTB) THEN - IF (NOTA) THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 50 I = 1,M - C(I,J) = ZERO - 50 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 60 I = 1,M - C(I,J) = BETA*C(I,J) - 60 CONTINUE - END IF - DO 80 L = 1,K - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - ELSE -* -* Form C := alpha*A**T*B + beta*C -* - DO 120 J = 1,N - DO 110 I = 1,M - TEMP = ZERO - DO 100 L = 1,K - TEMP = TEMP + A(L,I)*B(L,J) - 100 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 110 CONTINUE - 120 CONTINUE - END IF - ELSE - IF (NOTA) THEN -* -* Form C := alpha*A*B**T + beta*C -* - DO 170 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 130 I = 1,M - C(I,J) = ZERO - 130 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 140 I = 1,M - C(I,J) = BETA*C(I,J) - 140 CONTINUE - END IF - DO 160 L = 1,K - TEMP = ALPHA*B(J,L) - DO 150 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - ELSE -* -* Form C := alpha*A**T*B**T + beta*C -* - DO 200 J = 1,N - DO 190 I = 1,M - TEMP = ZERO - DO 180 L = 1,K - TEMP = TEMP + A(L,I)*B(J,L) - 180 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 190 CONTINUE - 200 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMM . -* - END - - SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* -- Reference BLAS level2 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER INCX,INCY,LDA,M,N - CHARACTER TRANS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* Purpose: -* ============= -* -* DGEMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n matrix. -* -* Arguments: -* ========== -* -* TRANS is CHARACTER*1 -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. -* M is INTEGER -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* -* N is INTEGER -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* -* ALPHA is DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* -* A is DOUBLE PRECISION array, dimension ( LDA, N ) -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. -* -* LDA is INTEGER -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* -* X is DOUBLE PRECISION array, dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* -* INCX is INTEGER -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* -* BETA is DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* -* Y is DOUBLE PRECISION array, dimension at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry with BETA non-zero, the incremented array Y -* must contain the vector y. On exit, Y is overwritten by the -* updated vector y. -* -* INCY is INTEGER -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* -* Further Details: -* ===================== -* -* Level 2 Blas routine. -* The vector and matrix arguments are not referenced when N = 0, or M = 0 -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 1 - ELSE IF (M.LT.0) THEN - INFO = 2 - ELSE IF (N.LT.0) THEN - INFO = 3 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - ELSE IF (INCY.EQ.0) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGEMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF (LSAME(TRANS,'N')) THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (LENX-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (LENY-1)*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF (BETA.NE.ONE) THEN - IF (INCY.EQ.1) THEN - IF (BETA.EQ.ZERO) THEN - DO 10 I = 1,LENY - Y(I) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1,LENY - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ELSE - IY = KY - IF (BETA.EQ.ZERO) THEN - DO 30 I = 1,LENY - Y(IY) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1,LENY - Y(IY) = BETA*Y(IY) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF (ALPHA.EQ.ZERO) RETURN - IF (LSAME(TRANS,'N')) THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF (INCY.EQ.1) THEN - DO 60 J = 1,N - TEMP = ALPHA*X(JX) - DO 50 I = 1,M - Y(I) = Y(I) + TEMP*A(I,J) - 50 CONTINUE - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80 J = 1,N - TEMP = ALPHA*X(JX) - IY = KY - DO 70 I = 1,M - Y(IY) = Y(IY) + TEMP*A(I,J) - IY = IY + INCY - 70 CONTINUE - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A**T*x + y. -* - JY = KY - IF (INCX.EQ.1) THEN - DO 100 J = 1,N - TEMP = ZERO - DO 90 I = 1,M - TEMP = TEMP + A(I,J)*X(I) - 90 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120 J = 1,N - TEMP = ZERO - IX = KX - DO 110 I = 1,M - TEMP = TEMP + A(I,J)*X(IX) - IX = IX + INCX - 110 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMV . -* - END - - SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* -- Reference BLAS level2 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of -* Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX,INCY,LDA,M,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER(ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,J,JY,KX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (M.LT.0) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (INCX.EQ.0) THEN - INFO = 5 - ELSE IF (INCY.EQ.0) THEN - INFO = 7 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGER ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (INCY.GT.0) THEN - JY = 1 - ELSE - JY = 1 - (N-1)*INCY - END IF - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*Y(JY) - DO 10 I = 1,M - A(I,J) = A(I,J) + X(I)*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (M-1)*INCX - END IF - DO 40 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*Y(JY) - IX = KX - DO 30 I = 1,M - A(I,J) = A(I,J) + X(IX)*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of DGER . -* - END - - DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION X(*) -* .. -* -* Purpose: -* ============= -* -* DNRM2 returns the euclidean norm of a vector via the function -* name, so that -* -* DNRM2 := sqrt( x'*x ) -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* Further Details: -* ===================== -* -* -- This version written on 25-October-1982. -* Modified on 14-October-1993 to inline the call to DLASSQ. -* Sven Hammarling, Nag Ltd. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ - INTEGER IX -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS,SQRT -* .. - IF (N.LT.1 .OR. INCX.LT.1) THEN - NORM = ZERO - ELSE IF (N.EQ.1) THEN - NORM = ABS(X(1)) - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10 IX = 1,1 + (N-1)*INCX,INCX - IF (X(IX).NE.ZERO) THEN - ABSXI = ABS(X(IX)) - IF (SCALE.LT.ABSXI) THEN - SSQ = ONE + SSQ* (SCALE/ABSXI)**2 - SCALE = ABSXI - ELSE - SSQ = SSQ + (ABSXI/SCALE)**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE*SQRT(SSQ) - END IF -* - DNRM2 = NORM - RETURN -* -* End of DNRM2. -* - END - - SUBROUTINE DSCAL(N,DA,DX,INCX) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - DOUBLE PRECISION DA - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* Purpose: -* ============= -* -* DSCAL scales a vector by a constant. -* uses unrolled loops for increment equal to 1. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DA is DOUBLE PRECISION On entry, DA specifies the scalar alpha. -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 3/93 to return if incx .le. 0. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,M,MP1,NINCX -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0 .OR. INCX.LE.0) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* -* -* clean-up loop -* - M = MOD(N,5) - IF (M.NE.0) THEN - DO I = 1,M - DX(I) = DA*DX(I) - END DO - IF (N.LT.5) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,5 - DX(I) = DA*DX(I) - DX(I+1) = DA*DX(I+1) - DX(I+2) = DA*DX(I+2) - DX(I+3) = DA*DX(I+3) - DX(I+4) = DA*DX(I+4) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - DX(I) = DA*DX(I) - END DO - END IF - RETURN - END - - SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* Purpose: -* ============= -* -* DSWAP interchanges two vectors. -* uses unrolled loops for increments equal to 1. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of DX -* -* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -* -* INCY is INTEGER storage spacing between elements of DY -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,3) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - END DO - IF (N.LT.3) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,3 - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - DTEMP = DX(I+1) - DX(I+1) = DY(I+1) - DY(I+1) = DTEMP - DTEMP = DX(I+2) - DX(I+2) = DY(I+2) - DY(I+2) = DTEMP - END DO - ELSE -* -* code for unequal increments or equal increments 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 I = 1,N - DTEMP = DX(IX) - DX(IX) = DY(IY) - DY(IY) = DTEMP - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN - END - - SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* -- Reference BLAS level3 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of -* Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER LDA,LDB,M,N - CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,K,NROWA - LOGICAL LSIDE,NOUNIT,UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Test the input parameters. -* - LSIDE = LSAME(SIDE,'L') - IF (LSIDE) THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME(DIAG,'N') - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN - INFO = 1 - ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 2 - ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. - + (.NOT.LSAME(TRANSA,'T')) .AND. - + (.NOT.LSAME(TRANSA,'C'))) THEN - INFO = 3 - ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN - INFO = 4 - ELSE IF (M.LT.0) THEN - INFO = 5 - ELSE IF (N.LT.0) THEN - INFO = 6 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDB.LT.MAX(1,M)) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (M.EQ.0 .OR. N.EQ.0) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - B(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF (LSIDE) THEN - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*A*B. -* - IF (UPPER) THEN - DO 50 J = 1,N - DO 40 K = 1,M - IF (B(K,J).NE.ZERO) THEN - TEMP = ALPHA*B(K,J) - DO 30 I = 1,K - 1 - B(I,J) = B(I,J) + TEMP*A(I,K) - 30 CONTINUE - IF (NOUNIT) TEMP = TEMP*A(K,K) - B(K,J) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80 J = 1,N - DO 70 K = M,1,-1 - IF (B(K,J).NE.ZERO) THEN - TEMP = ALPHA*B(K,J) - B(K,J) = TEMP - IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) - DO 60 I = K + 1,M - B(I,J) = B(I,J) + TEMP*A(I,K) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A**T*B. -* - IF (UPPER) THEN - DO 110 J = 1,N - DO 100 I = M,1,-1 - TEMP = B(I,J) - IF (NOUNIT) TEMP = TEMP*A(I,I) - DO 90 K = 1,I - 1 - TEMP = TEMP + A(K,I)*B(K,J) - 90 CONTINUE - B(I,J) = ALPHA*TEMP - 100 CONTINUE - 110 CONTINUE - ELSE - DO 140 J = 1,N - DO 130 I = 1,M - TEMP = B(I,J) - IF (NOUNIT) TEMP = TEMP*A(I,I) - DO 120 K = I + 1,M - TEMP = TEMP + A(K,I)*B(K,J) - 120 CONTINUE - B(I,J) = ALPHA*TEMP - 130 CONTINUE - 140 CONTINUE - END IF - END IF - ELSE - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*B*A. -* - IF (UPPER) THEN - DO 180 J = N,1,-1 - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 150 I = 1,M - B(I,J) = TEMP*B(I,J) - 150 CONTINUE - DO 170 K = 1,J - 1 - IF (A(K,J).NE.ZERO) THEN - TEMP = ALPHA*A(K,J) - DO 160 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - ELSE - DO 220 J = 1,N - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 190 I = 1,M - B(I,J) = TEMP*B(I,J) - 190 CONTINUE - DO 210 K = J + 1,N - IF (A(K,J).NE.ZERO) THEN - TEMP = ALPHA*A(K,J) - DO 200 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 200 CONTINUE - END IF - 210 CONTINUE - 220 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A**T. -* - IF (UPPER) THEN - DO 260 K = 1,N - DO 240 J = 1,K - 1 - IF (A(J,K).NE.ZERO) THEN - TEMP = ALPHA*A(J,K) - DO 230 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 230 CONTINUE - END IF - 240 CONTINUE - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(K,K) - IF (TEMP.NE.ONE) THEN - DO 250 I = 1,M - B(I,K) = TEMP*B(I,K) - 250 CONTINUE - END IF - 260 CONTINUE - ELSE - DO 300 K = N,1,-1 - DO 280 J = K + 1,N - IF (A(J,K).NE.ZERO) THEN - TEMP = ALPHA*A(J,K) - DO 270 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 270 CONTINUE - END IF - 280 CONTINUE - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(K,K) - IF (TEMP.NE.ONE) THEN - DO 290 I = 1,M - B(I,K) = TEMP*B(I,K) - 290 CONTINUE - END IF - 300 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMM . -* - END - - SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* -- Reference BLAS level2 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of -* Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER INCX,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER(ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,J,JX,KX - LOGICAL NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := A*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - DO 10 I = 1,J - 1 - X(I) = X(I) + TEMP*A(I,J) - 10 CONTINUE - IF (NOUNIT) X(J) = X(J)*A(J,J) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 30 I = 1,J - 1 - X(IX) = X(IX) + TEMP*A(I,J) - IX = IX + INCX - 30 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*A(J,J) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - DO 50 I = N,J + 1,-1 - X(I) = X(I) + TEMP*A(I,J) - 50 CONTINUE - IF (NOUNIT) X(J) = X(J)*A(J,J) - END IF - 60 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 80 J = N,1,-1 - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 70 I = N,J + 1,-1 - X(IX) = X(IX) + TEMP*A(I,J) - IX = IX - INCX - 70 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*A(J,J) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A**T*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 100 J = N,1,-1 - TEMP = X(J) - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 90 I = J - 1,1,-1 - TEMP = TEMP + A(I,J)*X(I) - 90 CONTINUE - X(J) = TEMP - 100 CONTINUE - ELSE - JX = KX + (N-1)*INCX - DO 120 J = N,1,-1 - TEMP = X(JX) - IX = JX - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 110 I = J - 1,1,-1 - IX = IX - INCX - TEMP = TEMP + A(I,J)*X(IX) - 110 CONTINUE - X(JX) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 140 J = 1,N - TEMP = X(J) - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 130 I = J + 1,N - TEMP = TEMP + A(I,J)*X(I) - 130 CONTINUE - X(J) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160 J = 1,N - TEMP = X(JX) - IX = JX - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 150 I = J + 1,N - IX = IX + INCX - TEMP = TEMP + A(I,J)*X(IX) - 150 CONTINUE - X(JX) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMV . -* - END - - SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* -- Reference BLAS level3 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER LDA,LDB,M,N - CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*) -* .. -* -* Purpose: -* ============= -* -* DTRSM solves one of the matrix equations -* -* op( A )*X = alpha*B, or X*op( A ) = alpha*B, -* -* where alpha is a scalar, X and B are m by n matrices, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A**T. -* -* The matrix X is overwritten on B. -* -* Arguments: -* ========== -* -* SIDE is CHARACTER*1 -* On entry, SIDE specifies whether op( A ) appears on the left -* or right of X as follows: -* -* SIDE = 'L' or 'l' op( A )*X = alpha*B. -* -* SIDE = 'R' or 'r' X*op( A ) = alpha*B. -* -* UPLO is CHARACTER*1 -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* TRANSA is CHARACTER*1 -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n' op( A ) = A. -* -* TRANSA = 'T' or 't' op( A ) = A**T. -* -* TRANSA = 'C' or 'c' op( A ) = A**T. -* -* DIAG is CHARACTER*1 -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* M is INTEGER -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* -* N is INTEGER -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* -* ALPHA is DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* -* A is DOUBLE PRECISION array, dimension ( LDA, k ), -* where k is m when SIDE = 'L' or 'l' -* and k is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* -* LDA is INTEGER -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* -* B is DOUBLE PRECISION array, dimension ( LDB, N ) -* Before entry, the leading m by n part of the array B must -* contain the right-hand side matrix B, and on exit is -* overwritten by the solution matrix X. -* -* LDB is INTEGER -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* -* Further Details: -* ===================== -* -* Level 3 Blas routine. -* -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,K,NROWA - LOGICAL LSIDE,NOUNIT,UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Test the input parameters. -* - LSIDE = LSAME(SIDE,'L') - IF (LSIDE) THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME(DIAG,'N') - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN - INFO = 1 - ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 2 - ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. - + (.NOT.LSAME(TRANSA,'T')) .AND. - + (.NOT.LSAME(TRANSA,'C'))) THEN - INFO = 3 - ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN - INFO = 4 - ELSE IF (M.LT.0) THEN - INFO = 5 - ELSE IF (N.LT.0) THEN - INFO = 6 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDB.LT.MAX(1,M)) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRSM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (M.EQ.0 .OR. N.EQ.0) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - B(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF (LSIDE) THEN - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*inv( A )*B. -* - IF (UPPER) THEN - DO 60 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 30 I = 1,M - B(I,J) = ALPHA*B(I,J) - 30 CONTINUE - END IF - DO 50 K = M,1,-1 - IF (B(K,J).NE.ZERO) THEN - IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) - DO 40 I = 1,K - 1 - B(I,J) = B(I,J) - B(K,J)*A(I,K) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 70 I = 1,M - B(I,J) = ALPHA*B(I,J) - 70 CONTINUE - END IF - DO 90 K = 1,M - IF (B(K,J).NE.ZERO) THEN - IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) - DO 80 I = K + 1,M - B(I,J) = B(I,J) - B(K,J)*A(I,K) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A**T )*B. -* - IF (UPPER) THEN - DO 130 J = 1,N - DO 120 I = 1,M - TEMP = ALPHA*B(I,J) - DO 110 K = 1,I - 1 - TEMP = TEMP - A(K,I)*B(K,J) - 110 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(I,I) - B(I,J) = TEMP - 120 CONTINUE - 130 CONTINUE - ELSE - DO 160 J = 1,N - DO 150 I = M,1,-1 - TEMP = ALPHA*B(I,J) - DO 140 K = I + 1,M - TEMP = TEMP - A(K,I)*B(K,J) - 140 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(I,I) - B(I,J) = TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*B*inv( A ). -* - IF (UPPER) THEN - DO 210 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 170 I = 1,M - B(I,J) = ALPHA*B(I,J) - 170 CONTINUE - END IF - DO 190 K = 1,J - 1 - IF (A(K,J).NE.ZERO) THEN - DO 180 I = 1,M - B(I,J) = B(I,J) - A(K,J)*B(I,K) - 180 CONTINUE - END IF - 190 CONTINUE - IF (NOUNIT) THEN - TEMP = ONE/A(J,J) - DO 200 I = 1,M - B(I,J) = TEMP*B(I,J) - 200 CONTINUE - END IF - 210 CONTINUE - ELSE - DO 260 J = N,1,-1 - IF (ALPHA.NE.ONE) THEN - DO 220 I = 1,M - B(I,J) = ALPHA*B(I,J) - 220 CONTINUE - END IF - DO 240 K = J + 1,N - IF (A(K,J).NE.ZERO) THEN - DO 230 I = 1,M - B(I,J) = B(I,J) - A(K,J)*B(I,K) - 230 CONTINUE - END IF - 240 CONTINUE - IF (NOUNIT) THEN - TEMP = ONE/A(J,J) - DO 250 I = 1,M - B(I,J) = TEMP*B(I,J) - 250 CONTINUE - END IF - 260 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A**T ). -* - IF (UPPER) THEN - DO 310 K = N,1,-1 - IF (NOUNIT) THEN - TEMP = ONE/A(K,K) - DO 270 I = 1,M - B(I,K) = TEMP*B(I,K) - 270 CONTINUE - END IF - DO 290 J = 1,K - 1 - IF (A(J,K).NE.ZERO) THEN - TEMP = A(J,K) - DO 280 I = 1,M - B(I,J) = B(I,J) - TEMP*B(I,K) - 280 CONTINUE - END IF - 290 CONTINUE - IF (ALPHA.NE.ONE) THEN - DO 300 I = 1,M - B(I,K) = ALPHA*B(I,K) - 300 CONTINUE - END IF - 310 CONTINUE - ELSE - DO 360 K = 1,N - IF (NOUNIT) THEN - TEMP = ONE/A(K,K) - DO 320 I = 1,M - B(I,K) = TEMP*B(I,K) - 320 CONTINUE - END IF - DO 340 J = K + 1,N - IF (A(J,K).NE.ZERO) THEN - TEMP = A(J,K) - DO 330 I = 1,M - B(I,J) = B(I,J) - TEMP*B(I,K) - 330 CONTINUE - END IF - 340 CONTINUE - IF (ALPHA.NE.ONE) THEN - DO 350 I = 1,M - B(I,K) = ALPHA*B(I,K) - 350 CONTINUE - END IF - 360 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSM . -* - END - - INTEGER FUNCTION IDAMAX(N,DX,INCX) -* -* -- Reference BLAS level1 routine (version 3.8.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2017 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* Purpose: -* ============= -* -* IDAMAX finds the index of the first element having maximum absolute value. -* -* Arguments: -* ========== -* -* N is INTEGER number of elements in input vector(s) -* -* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -* -* INCX is INTEGER storage spacing between elements of SX -* -* Further Details: -* ===================== -* -* jack dongarra, linpack, 3/11/78. -* modified 3/93 to return if incx .le. 0. -* modified 12/3/93, array(1) declarations changed to array(*) -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DMAX - INTEGER I,IX -* .. -* .. Intrinsic Functions .. - INTRINSIC DABS -* .. - IDAMAX = 0 - IF (N.LT.1 .OR. INCX.LE.0) RETURN - IDAMAX = 1 - IF (N.EQ.1) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* - DMAX = DABS(DX(1)) - DO I = 2,N - IF (DABS(DX(I)).GT.DMAX) THEN - IDAMAX = I - DMAX = DABS(DX(I)) - END IF - END DO - ELSE -* -* code for increment not equal to 1 -* - IX = 1 - DMAX = DABS(DX(1)) - IX = IX + INCX - DO I = 2,N - IF (DABS(DX(IX)).GT.DMAX) THEN - IDAMAX = I - DMAX = DABS(DX(IX)) - END IF - IX = IX + INCX - END DO - END IF - RETURN - END - - LOGICAL FUNCTION LSAME(CA,CB) -* -* -- Reference BLAS level1 routine (version 3.1) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - CHARACTER CA,CB -* .. -* -* Purpose: -* ============= -* -* LSAME returns .TRUE. if CA is the same letter as CB regardless of -* case. -* -* Arguments: -* ========== -* -* CA is CHARACTER*1 -* CB is CHARACTER*1 -* CA and CB specify the single characters to be compared. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ICHAR -* .. -* .. Local Scalars .. - INTEGER INTA,INTB,ZCODE -* .. -* -* Test if the characters are equal -* - LSAME = CA .EQ. CB - IF (LSAME) RETURN -* -* Now test for equivalence if both characters are alphabetic. -* - ZCODE = ICHAR('Z') -* -* Use 'Z' rather than 'A' so that ASCII can be detected on Prime -* machines, on which ICHAR returns a value with bit 8 set. -* ICHAR('A') on Prime machines returns 193 which is the same as -* ICHAR('A') on an EBCDIC machine. -* - INTA = ICHAR(CA) - INTB = ICHAR(CB) -* - IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN -* -* ASCII is assumed - ZCODE is the ASCII code of either lower or -* upper case 'Z'. -* - IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 - IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 -* - ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN -* -* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or -* upper case 'Z'. -* - IF (INTA.GE.129 .AND. INTA.LE.137 .OR. - + INTA.GE.145 .AND. INTA.LE.153 .OR. - + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 - IF (INTB.GE.129 .AND. INTB.LE.137 .OR. - + INTB.GE.145 .AND. INTB.LE.153 .OR. - + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 -* - ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN -* -* ASCII is assumed, on Prime machines - ZCODE is the ASCII code -* plus 128 of either lower or upper case 'Z'. -* - IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 - IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 - END IF - LSAME = INTA .EQ. INTB -* -* RETURN -* -* End of LSAME -* - END - - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* -- Reference BLAS level1 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - CHARACTER*(*) SRNAME - INTEGER INFO -* .. -* -* Purpose: -* ============= -* -* XERBLA is an error handler for the LAPACK routines. -* It is called by an LAPACK routine if an input parameter has an -* invalid value. A message is printed and execution stops. -* -* Installers may consider modifying the STOP statement in order to -* call system-specific exception-handling facilities. -* -* Arguments: -* ========== -* -* SRNAME is CHARACTER*(*) -* The name of the routine which called XERBLA. -* -* INFO is INTEGER -* The position of the invalid parameter in the parameter list -* of the calling routine. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC LEN_TRIM -* .. -* .. Executable Statements .. -* - WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO -* - STOP -* - 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', - $ 'an illegal value' ) -* -* End of XERBLA -* - END - diff --git a/toms1012/delsparse.f90 b/toms1012/delsparse.f90 deleted file mode 100644 index b093f9a..0000000 --- a/toms1012/delsparse.f90 +++ /dev/null @@ -1,2778 +0,0 @@ -MODULE REAL_PRECISION ! HOMPACK90 module for 64-bit arithmetic. -INTEGER, PARAMETER:: R8=SELECTED_REAL_KIND(13) -END MODULE REAL_PRECISION - -MODULE DELSPARSE_MOD -! This module contains the REAL_PRECISION R8 data type for 64-bit arithmetic -! and interface blocks for the DELAUNAYSPARSES and DELAUNAYSPARSEP -! subroutines for computing the Delaunay simplices containing interpolation -! points Q in R^D given data points PTS. -USE REAL_PRECISION -PUBLIC - -INTERFACE - ! Interface for serial subroutine DELAUNAYSPARSES. - SUBROUTINE DELAUNAYSPARSES( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, & - IBUDGET, CHAIN, EXACT ) - USE REAL_PRECISION, ONLY : R8 - INTEGER, INTENT(IN) :: D, N - REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) - INTEGER, INTENT(IN) :: M - REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) - INTEGER, INTENT(OUT) :: SIMPS(:,:) - REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) - INTEGER, INTENT(OUT) :: IERR(:) - REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) - REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) - INTEGER, INTENT(IN), OPTIONAL :: IBUDGET - LOGICAL, INTENT(IN), OPTIONAL :: CHAIN - LOGICAL, INTENT(IN), OPTIONAL :: EXACT - END SUBROUTINE DELAUNAYSPARSES - - ! Interface for parallel subroutine DELAUNAYSPARSEP. - SUBROUTINE DELAUNAYSPARSEP( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, & - IBUDGET, CHAIN, EXACT, PMODE ) - USE REAL_PRECISION, ONLY : R8 - INTEGER, INTENT(IN) :: D, N - REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) - INTEGER, INTENT(IN) :: M - REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) - INTEGER, INTENT(OUT) :: SIMPS(:,:) - REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) - INTEGER, INTENT(OUT) :: IERR(:) - REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) - REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP - REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) - INTEGER, INTENT(IN), OPTIONAL :: IBUDGET - LOGICAL, INTENT(IN), OPTIONAL :: CHAIN - LOGICAL, INTENT(IN), OPTIONAL :: EXACT - INTEGER, INTENT(IN), OPTIONAL :: PMODE - END SUBROUTINE DELAUNAYSPARSEP - - ! Interface for SLATEC subroutine DWNNLS. - SUBROUTINE DWNNLS( W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, & - MODE, IWORK, WORK ) - USE REAL_PRECISION, ONLY : R8 - INTEGER :: IWORK(*), L, MA, MDW, ME, MODE, N - REAL(KIND=R8) :: PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) - END SUBROUTINE DWNNLS - -END INTERFACE - -END MODULE DELSPARSE_MOD - -SUBROUTINE DELAUNAYSPARSES( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EXACT ) -! This is a serial implementation of an algorithm for efficiently performing -! interpolation in R^D via the Delaunay triangulation. The algorithm is fully -! described and analyzed in -! -! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. -! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate -! interpolation in arbitrary dimension via the Delaunay triangulation. In -! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, -! USA. Article 12, 8 pages. -! -! -! On input: -! -! D is the dimension of the space for PTS and Q. -! -! N is the number of data points in PTS. -! -! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the -! coordinates of a single data point in R^D. -! -! M is the number of interpolation points in Q. -! -! Q(1:D,1:M) is a real valued matrix with M columns, each containing the -! coordinates of a single interpolation point in R^D. -! -! -! On output: -! -! PTS and Q have been rescaled and shifted. All the data points in PTS -! are now contained in the unit hyperball in R^D, and the points in Q -! have been shifted and scaled accordingly in relation to PTS. -! -! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns -! in PTS) for the D+1 vertices of the Delaunay simplex containing each -! interpolation point in Q. -! -! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each -! point in Q as a convex combination of the D+1 corresponding vertices -! in SIMPS. -! -! IERR(1:M) contains integer valued error flags associated with the -! computation of each of the M interpolation points in Q. The error -! codes are: -! -! 00 : Succesful interpolation. -! 01 : Succesful extrapolation (up to the allowed extrapolation distance). -! 02 : This point was outside the allowed extrapolation distance; the -! corresponding entries in SIMPS and WEIGHTS contain zero values. -! -! 10 : The dimension D must be positive. -! 11 : Too few data points to construct a triangulation (i.e., N < D+1). -! 12 : No interpolation points given (i.e., M < 1). -! 13 : The first dimension of PTS does not agree with the dimension D. -! 14 : The second dimension of PTS does not agree with the number of points N. -! 15 : The first dimension of Q does not agree with the dimension D. -! 16 : The second dimension of Q does not agree with the number of -! interpolation points M. -! 17 : The first dimension of the output array SIMPS does not match the number -! of vertices needed for a D-simplex (D+1). -! 18 : The second dimension of the output array SIMPS does not match the -! number of interpolation points M. -! 19 : The first dimension of the output array WEIGHTS does not match the -! number of vertices for a a D-simplex (D+1). -! 20 : The second dimension of the output array WEIGHTS does not match the -! number of interpolation points M. -! 21 : The size of the error array IERR does not match the number of -! interpolation points M. -! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. -! 23 : The first dimension of INTERP_IN does not match the first -! dimension of INTERP_OUT. -! 24 : The second dimension of INTERP_IN does not match the number of -! data points PTS. -! 25 : The second dimension of INTERP_OUT does not match the number of -! interpolation points M. -! 26 : The budget supplied in IBUDGET does not contain a positive -! integer. -! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. -! 28 : The size of the RNORM output array does not match the number of -! interpolation points M. -! -! 30 : Two or more points in the data set PTS are too close together with -! respect to the working precision (EPS), which would result in a -! numerically degenerate simplex. -! 31 : All the data points in PTS lie in some lower dimensional linear -! manifold (up to the working precision), and no valid triangulation -! exists. -! 40 : An error caused DELAUNAYSPARSES to terminate before this value could -! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may -! contain garbage values. -! -! 50 : A memory allocation error occurred while allocating the work array -! WORK. -! -! 60 : The budget was exceeded before the algorithm converged on this -! value. If the dimension is high, try increasing IBUDGET. This -! error can also be caused by a working precision EPS that is too -! small for the conditioning of the problem. -! -! 61 : A value that was judged appropriate later caused LAPACK to encounter a -! singularity. Try increasing the value of EPS. -! -! 70 : Allocation error for the extrapolation work arrays. -! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection -! of an extrapolation point onto the convex hull. -! 72 : The SLATEC subroutine DWNNLS has reported a usage error. -! -! The errors 72, 80--83 should never occur, and likely indicate a -! compiler bug or hardware failure. -! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. -! 81 : The LAPACK subroutine DGETRF has reported an illegal value. -! 82 : The LAPACK subroutine DGETRS has reported an illegal value. -! 83 : The LAPACK subroutine DORMQR has reported an illegal value. -! -! -! Optional arguments: -! -! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of -! the data points in PTS on input. The first dimension of INTERP_IN is -! inferred to be the dimension of these response vectors, and the -! second dimension must match N. If present, the response values will -! be computed for each interpolation point in Q, and stored in INTERP_OUT, -! which therefore must also be present. If both INTERP_IN and INTERP_OUT -! are omitted, only the containing simplices and convex combination -! weights are returned. -! -! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each -! interpolation point in Q on output. The first dimension of INTERP_OUT -! must match the first dimension of INTERP_IN, and the second dimension -! must match M. If present, the response values at each interpolation -! point are computed as a convex combination of the response values -! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing -! that interpolation point. Therefore, if INTERP_OUT is present, then -! INTERP_IN must also be present. If both are omitted, only the -! simplices and convex combination weights are returned. -! -! EPS contains the real working precision for the problem on input. By default, -! EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff for the -! machine. In general, any values that differ by less than EPS are judged -! as equal, and any weights that are greater than -EPS are judged as -! nonnegative. EPS cannot take a value less than the default value of -! \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, the default -! value will be used instead automatically. -! -! EXTRAP contains the real maximum extrapolation distance (relative to the -! diameter of PTS) on input. Interpolation at a point outside the convex -! hull of PTS is done by projecting that point onto the convex hull, and -! then doing normal Delaunay interpolation at that projection. -! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) -! units outside the convex hull of PTS will not be done and an error code -! of 2 will be returned. Note that computing the projection can be -! expensive. Setting EXTRAP=0 will cause all extrapolation points to be -! ignored without ever computing a projection. By default, EXTRAP=0.1 -! (extrapolate by up to 10% of the diameter of PTS). -! -! RNORM(1:M) contains the real unscaled projection (2-norm) distances from -! any projection computations on output. If not present, these distances -! are still computed for each extrapolation point, but are never returned. -! -! IBUDGET on input contains the integer budget for performing flips while -! iterating toward the simplex containing each interpolation point in -! Q. This prevents DELAUNAYSPARSES from falling into an infinite loop when -! an inappropriate value of EPS is given with respect to the problem -! conditioning. By default, IBUDGET=50000. However, for extremely -! high-dimensional problems and pathological inputs, the default value -! may be insufficient. -! -! CHAIN is a logical input argument that determines whether a new first -! simplex should be constructed for each interpolation point -! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." -! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not -! recommended, unless the size of the triangulation is relatively small -! or the interpolation points are known to be tightly clustered. -! -! EXACT is a logical input argument that determines whether the exact -! diameter should be computed and whether a check for duplicate data -! points should be performed in advance. When EXACT=.FALSE., the -! diameter of PTS is approximated by twice the distance from the -! barycenter of PTS to the farthest point in PTS, and no check is -! done to find the closest pair of points, which could result in hard -! to find bugs later on. When EXACT=.TRUE., the exact diameter is -! computed and an error is returned whenever PTS contains duplicate -! values up to the precision EPS. By default EXACT=.TRUE., but setting -! EXACT=.FALSE. could result in significant speedup when N is large. -! It is strongly recommended that most users leave EXACT=.TRUE., as -! setting EXACT=.FALSE. could result in input errors that are difficult -! to identify. Also, the diameter approximation could be wrong by up to -! a factor of two. -! -! -! Subroutines and functions directly referenced from BLAS are -! DDOT, DGEMV, DNRM2, DTRSM, -! and from LAPACK are -! DGEQP3, DGETRF, DGETRS, DORMQR. -! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its -! SLATEC dependencies have been slightly edited to comply with the Fortran -! 2008 standard, with all print statements and references to stderr being -! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 -! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS -! Algorithm 777) is used for the real data type. The REAL_PRECISION module, -! DELAUNAYSPARSES, and DWNNLS and its dependencies comply with the Fortran -! 2008 standard. -! -! Primary Author: Tyler H. Chang -! Last Update: March, 2020 -! -USE REAL_PRECISION, ONLY : R8 -IMPLICIT NONE - -! Input arguments. -INTEGER, INTENT(IN) :: D, N -REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) ! Rescaled on output. -INTEGER, INTENT(IN) :: M -REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) ! Rescaled on output. -! Output arguments. -INTEGER, INTENT(OUT) :: SIMPS(:,:) -REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) -INTEGER, INTENT(OUT) :: IERR(:) -! Optional arguments. -REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) -REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) -REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP -REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) -INTEGER, INTENT(IN), OPTIONAL :: IBUDGET -LOGICAL, INTENT(IN), OPTIONAL :: CHAIN -LOGICAL, INTENT(IN), OPTIONAL :: EXACT - -! Local copies of optional input arguments. -REAL(KIND=R8) :: EPSL, EXTRAPL -INTEGER :: IBUDGETL -LOGICAL :: CHAINL, EXACTL - -! Local variables. -INTEGER :: I, J, K ! Loop iteration variables. -INTEGER :: IEXTRAPS ! Extrapolation budget. -INTEGER :: ITMP, JTMP ! Temporary variables for swapping, looping, etc. -INTEGER :: LWORK ! Size of the work array. -INTEGER :: MI ! Index of current interpolation point. -REAL(KIND=R8) :: CURRRAD ! Radius of the current circumsphere. -REAL(KIND=R8) :: MINRAD ! Minimum circumsphere radius observed. -REAL(KIND=R8) :: PTS_DIAM ! Scaled diameter of data set. -REAL(KIND=R8) :: PTS_SCALE ! Data scaling factor. -REAL(KIND=R8) :: RNORML ! Euclidean norm of the projection residual. -REAL(KIND=R8) :: SIDE1, SIDE2 ! Signs (+/-1) denoting sides of a facet. - -! Local arrays, requiring O(d^2) additional memory. -INTEGER :: IPIV(D) ! Pivot indices. -INTEGER :: SEED(D+1) ! Copy of the SEED simplex. Only used if CHAIN = .TRUE. -REAL(KIND=R8) :: AT(D,D) ! The transpose of A, the linear coefficient matrix. -REAL(KIND=R8) :: B(D) ! The RHS of a linear system. -REAL(KIND=R8) :: CENTER(D) ! The circumcenter of a simplex. -REAL(KIND=R8) :: LQ(D,D) ! Holds LU or QR factorization of AT. -REAL(KIND=R8) :: PLANE(D+1) ! The hyperplane containing a facet. -REAL(KIND=R8) :: PRGOPT_DWNNLS(1) ! Options array for DWNNLS. -REAL(KIND=R8) :: PROJ(D) ! The projection of the current iterate. -REAL(KIND=R8) :: TAU(D) ! Householder reflector constants. -REAL(KIND=R8) :: X(D) ! The solution to a linear system. - -! Extrapolation work arrays are only allocated if DWNNLS is called. -INTEGER, ALLOCATABLE :: IWORK_DWNNLS(:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: W_DWNNLS(:,:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: WORK(:) ! Allocated with size LWORK. -REAL(KIND=R8), ALLOCATABLE :: WORK_DWNNLS(:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: X_DWNNLS(:) ! Only for DWNNLS. - -! External functions and subroutines. -REAL(KIND=R8), EXTERNAL :: DDOT ! Inner product (BLAS). -REAL(KIND=R8), EXTERNAL :: DNRM2 ! Euclidean norm (BLAS). -EXTERNAL :: DGEMV ! General matrix vector multiply (BLAS) -EXTERNAL :: DGEQP3 ! Perform a QR factorization with column pivoting (LAPACK). -EXTERNAL :: DGETRF ! Perform a LU factorization with partial pivoting (LAPACK). -EXTERNAL :: DGETRS ! Use the output of DGETRF to solve a linear system (LAPACK). -EXTERNAL :: DORMQR ! Apply householder reflectors to a matrix (LAPACK). -EXTERNAL :: DTRSM ! Perform a triangular solve (BLAS). -EXTERNAL :: DWNNLS ! Solve an inequality constrained least squares problem - ! (SLATEC). - -! Check for input size and dimension errors. -IF (D < 1) THEN ! The dimension must satisfy D > 0. - IERR(:) = 10; RETURN; END IF -IF (N < D+1) THEN ! Must have at least D+1 data points. - IERR(:) = 11; RETURN; END IF -IF (M < 1) THEN ! Must have at least one interpolation point. - IERR(:) = 12; RETURN; END IF -IF (SIZE(PTS,1) .NE. D) THEN ! Dimension of PTS array should match. - IERR(:) = 13; RETURN; END IF -IF (SIZE(PTS,2) .NE. N) THEN ! Number of data points should match. - IERR(:) = 14; RETURN; END IF -IF (SIZE(Q,1) .NE. D) THEN ! Dimension of Q should match. - IERR(:) = 15; RETURN; END IF -IF (SIZE(Q,2) .NE. M) THEN ! Number of interpolation points should match. - IERR(:) = 16; RETURN; END IF -IF (SIZE(SIMPS,1) .NE. D+1) THEN ! Need space for D+1 vertices per simplex. - IERR(:) = 17; RETURN; END IF -IF (SIZE(SIMPS,2) .NE. M) THEN ! There will be M output simplices. - IERR(:) = 18; RETURN; END IF -IF (SIZE(WEIGHTS,1) .NE. D+1) THEN ! There will be D+1 weights per simplex. - IERR(:) = 19; RETURN; END IF -IF (SIZE(WEIGHTS,2) .NE. M) THEN ! One vector of weights per simplex. - IERR(:) = 20; RETURN; END IF -IF (SIZE(IERR) .NE. M) THEN ! An error flag for each interpolation point. - IERR(:) = 21; RETURN; END IF - -! Check for optional arguments. -IF (PRESENT(INTERP_IN) .NEQV. PRESENT(INTERP_OUT)) THEN - IERR(:) = 22; RETURN; END IF -IF (PRESENT(INTERP_IN)) THEN ! Sizes must agree. - IF (SIZE(INTERP_IN,1) .NE. SIZE(INTERP_OUT,1)) THEN - IERR(:) = 23 ; RETURN; END IF - IF(SIZE(INTERP_IN,2) .NE. N) THEN - IERR(:) = 24; RETURN; END IF - IF (SIZE(INTERP_OUT,2) .NE. M) THEN - IERR(:) = 25; RETURN; END IF - INTERP_OUT(:,:) = 0.0_R8 ! Initialize output to zeros. -END IF -EPSL = SQRT(EPSILON(0.0_R8)) ! Get the machine unit roundoff constant. -IF (PRESENT(EPS)) THEN - IF (EPSL < EPS) THEN ! If the given precision is too small, ignore it. - EPSL = EPS - END IF -END IF -IF (PRESENT(IBUDGET)) THEN - IBUDGETL = IBUDGET ! Use the given budget if present. - IF (IBUDGETL < 1) THEN - IERR(:) = 26; RETURN; END IF -ELSE - IBUDGETL = 50000 ! Default value for budget. -END IF -IF (PRESENT(EXTRAP)) THEN - EXTRAPL = EXTRAP - IF (EXTRAPL < 0) THEN ! Check that the extrapolation distance is legal. - IERR(:) = 27; RETURN; END IF -ELSE - EXTRAPL = 0.1_R8 ! Default extrapolation distance (for normalized points). -END IF -IF (PRESENT(RNORM)) THEN - IF (SIZE(RNORM,1) .NE. M) THEN ! The length of the array must match. - IERR(:) = 28; RETURN; END IF - RNORM(:) = 0.0_R8 ! Initialize output to zeros. -END IF -IF (PRESENT(CHAIN)) THEN - CHAINL = CHAIN ! Turn chaining on, if necessarry. - SEED(:) = 0 ! Initialize SEED in case it is needed. -ELSE - CHAINL = .FALSE. -END IF -IF (PRESENT(EXACT)) THEN - EXACTL = EXACT ! Set error checking and exact diameter computations. -ELSE - EXACTL = .TRUE. -END IF - -! Scale and center the data points and interpolation points. -CALL RESCALE(MINRAD, PTS_DIAM, PTS_SCALE) -IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. - IERR(:) = 30; RETURN; END IF - -! Query DGEQP3 for optimal work array size (LWORK). -LWORK = -1 -CALL DGEQP3(D,D,LQ,D,IPIV,TAU,B,LWORK,IERR(1)) -LWORK = INT(B(1)) ! Compute the optimal work array size. -ALLOCATE(WORK(LWORK), STAT=I) ! Allocate WORK to size LWORK. -IF (I .NE. 0) THEN ! Check for memory allocation errors. - IERR(:) = 50; RETURN; END IF - -! Initialize all error codes to "TBD" values. -IERR(:) = 40 - -! Outer loop over all interpolation points (in Q). -OUTER : DO MI = 1, M - - ! Check if this interpolation point was already found. - IF (IERR(MI) .EQ. 0) CYCLE OUTER - - ! Initialize the projection and reset the residual. - PROJ(:) = Q(:,MI) - RNORML = 0.0_R8 - - ! Check if extrapolation is enabled. - IF (EXTRAPL < EPSL) THEN - IEXTRAPS = -1 ! If not, set the extrapolation budget negative. - ELSE - IEXTRAPS = 1 ! Allow for exactly one projection for this point. - END IF - - ! If there is no useable seed or if chaining is turned off, then make a new - ! simplex. - IF( (.NOT. CHAINL) .OR. SEED(1) .EQ. 0) THEN - CALL MAKEFIRSTSIMP() - IF(IERR(MI) .NE. 0) CYCLE OUTER - ! Otherwise, use the seed. - ELSE - ! Copy the seed to the current simplex. - SIMPS(:,MI) = SEED(:) - ! Rebuild the linear system. - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - - ! Inner loop searching for a simplex containing the point Q(:,MI). - INNER : DO K = 1, IBUDGETL - - ! If chaining is on, save each good simplex as the next seed. - IF (CHAINL) SEED(:) = SIMPS(:,MI) - - ! Check if the current simplex contains Q(:,MI). - IF (PTINSIMP()) EXIT INNER - IF (IERR(MI) .NE. 0) CYCLE OUTER ! Check for an error flag. - - ! Swap out the least weighted vertex, but save its value in case it - ! needs to be restored later. - JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) - ITMP = SIMPS(JTMP,MI) - SIMPS(JTMP,MI) = SIMPS(D+1,MI) - - ! If the least weighted vertex (index JTMP) is not the first vertex, - ! then just drop row (JTMP-1) from the linear system (corresponding - ! to column (JTMP-1) of A^T). - IF(JTMP .NE. 1) THEN - AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) - ! However, if JTMP = 1, then both A^T and B must be reconstructed. - ELSE - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - - ! Compute the next simplex (do one flip). - CALL MAKESIMPLEX() - IF (IERR(MI) .NE. 0) CYCLE OUTER - - ! If no vertex was found, then this is an extrapolation point. - IF (SIMPS(D+1,MI) .EQ. 0) THEN - - ! If extrapolation is not allowed (EXTRAP=0), do not proceed. - IF (IEXTRAPS < 0) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! Set the error flag and skip this point. - IERR(MI) = 2; CYCLE OUTER - - ! If extrapolation is allowed (EXTRAP>0), check the budget. - ELSE IF (IEXTRAPS .EQ. 0) THEN - ! A second projection has been attempted. This code is rarely - ! called, except in extreme cases involving nearly singular - ! simplices near the convex hull of P. - - ! Swap the weights to match the simplex indices, and zero the - ! most negative weight. - WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) - WEIGHTS(D+1,MI) = 0.0_R8 - ! Loop through all the remaining facets from which Q(:,MI) is - ! visible, and attempt to flip across each one. - DO WHILE (SIMPS(D+1,MI) .EQ. 0) - ! Restore the previous simplex and linear system. - SIMPS(D+1,MI) = ITMP - AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - ! Find the next most negative weight. - JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) - ! Check if WEIGHTS(JTMP,MI) .GE. 0. - IF (WEIGHTS(JTMP,MI) .GE. -EPSL) THEN - ! There is no other direction to flip, so Q(:,MI) must be - ! within EPSL of the current simplex. - ! Project Q(:,MI) onto the current simplex. - - ! Since at least one projection has already been done, - ! the work arrays have already been allocated. - PRGOPT_DWNNLS(1) = 1.0_R8 - IWORK_DWNNLS(1) = 6*D + 6 - IWORK_DWNNLS(2) = 2*D + 2 - ! Set equality constraint. - W_DWNNLS(1,1:D+2) = 1.0_R8 - ! Populate LS coefficient matrix and RHS. - FORALL (I=1:D+1) W_DWNNLS(2:D+1,I) = PTS(:,SIMPS(I,MI)) - W_DWNNLS(2:D+1,D+2) = PROJ(:) - ! Project onto the current simplex. - CALL DWNNLS(W_DWNNLS, D+1, 1, D, D+1, 0, PRGOPT_DWNNLS, & - WEIGHTS(:,MI), WORK(1), IERR(MI), IWORK_DWNNLS, & - WORK_DWNNLS) - IF (IERR(MI) .EQ. 1) THEN ! Failure to converge. - IERR(MI) = 71; CYCLE OUTER - ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. - IERR(MI) = 72; CYCLE OUTER - END IF - ! A solution has been found; return it. - EXIT INNER - END IF - ! Otherwise, swap the vertices. - ITMP = SIMPS(JTMP,MI) - SIMPS(JTMP,MI) = SIMPS(D+1,MI) - ! Swap the weights to match, and zero the most negative weight. - WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) - WEIGHTS(D+1,MI) = 0.0_R8 - ! If the least weighted vertex (index JTMP) is not the first - ! vertex, then just drop row (JTMP-1) from the linear system - ! (corresponding to column (JTMP-1) of A^T). - IF (JTMP .NE. 1) THEN - AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) - ! However, if JTMP=1, then both A^T and B must be reconstructed. - ELSE - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - ! Compute another simplex (try to flip again). - CALL MAKESIMPLEX(); IF (IERR(MI) .NE. 0) CYCLE OUTER - END DO - ! If the loop terminates, then a good direction was found. - ! Resume the visibility walk as normal. - CYCLE INNER - END IF - - ! Otherwise, project the extrapolation point onto the convex hull. - CALL PROJECT() - IF (IERR(MI) .NE. 0) CYCLE OUTER - - ! Check the value of RNORML for over-extrapolation. - IF (RNORML > EXTRAPL * PTS_DIAM) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! If present, record the unscaled RNORM output. - IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE - ! Set the error flag and skip this point. - IERR(MI) = 2; CYCLE OUTER - END IF - - ! Otherwise, restore the previous simplex and continue with the - ! projected value. - SIMPS(D+1,MI) = ITMP - AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - IEXTRAPS = IEXTRAPS - 1 ! Decrement the budget. - END IF - - ! End of inner loop for finding each interpolation point. - END DO INNER - - ! Check for budget violation conditions. - IF (K > IBUDGETL) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! Set the error flag and skip this point. - IERR(MI) = 60; CYCLE OUTER - END IF - - ! If the residual is nonzero, set the extrapolation flag. - IF (RNORML > EPSL) IERR(MI) = 1 - - ! If present, record the RNORM output. - IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE - -END DO OUTER ! End of outer loop over all interpolation points. - -! If INTERP_IN and INTERP_OUT are present, compute all values f(q). -IF (PRESENT(INTERP_IN)) THEN - ! Loop over all interpolation points. - DO MI = 1, M - ! Check for errors. - IF (IERR(MI) .LE. 1) THEN - ! Compute the weighted sum of vertex response values. - DO K = 1, D+1 - INTERP_OUT(:,MI) = INTERP_OUT(:,MI) & - + INTERP_IN(:,SIMPS(K,MI)) * WEIGHTS(K,MI) - END DO - END IF - END DO -END IF - -! Free dynamic work arrays. -DEALLOCATE(WORK) -IF (ALLOCATED(IWORK_DWNNLS)) DEALLOCATE(IWORK_DWNNLS) -IF (ALLOCATED(WORK_DWNNLS)) DEALLOCATE(WORK_DWNNLS) -IF (ALLOCATED(W_DWNNLS)) DEALLOCATE(W_DWNNLS) -IF (ALLOCATED(X_DWNNLS)) DEALLOCATE(X_DWNNLS) - -RETURN - -CONTAINS ! Internal subroutines and functions. - -SUBROUTINE MAKEFIRSTSIMP() -! Iteratively construct the first simplex by choosing points that -! minimize the radius of the smallest circumball. Let P_1, P_2, ..., P_K -! denote the current set of vertices for the simplex. Let P* denote the -! candidate vertex to be added to the simplex. Let CENTER denote the -! circumcenter of the simplex. Then -! -! X = CENTER - P_1 -! -! is given by the minimum norm solution to the underdetermined linear system -! -! A X = B, where -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_K - P_1, P* - P_1 ] and -! B = [ /2, /2, ..., /2 ]^T. -! -! Then the radius of the smallest circumsphere is CURRRAD = \| X \|, -! and the next vertex is given by P_{K+1} = argmin_{P*} CURRRAD, where P* -! ranges over points in PTS that are not already a vertex of the simplex. -! -! On output, this subroutine fully populates the matrix A^T and vector B, -! and fills SIMPS(:,MI) with the indices of a valid Delaunay simplex. - -! Find the first point, i.e., the closest point to Q(:,MI). -SIMPS(:,MI) = 0 -MINRAD = HUGE(0.0_R8) -DO I = 1, N - ! Check the distance to Q(:,MI). - CURRRAD = DNRM2(D, PTS(:,I) - PROJ(:), 1) - IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(1,MI) = I; END IF -END DO -! Find the second point, i.e., the closest point to PTS(:,SIMPS(1,MI)). -MINRAD = HUGE(0.0_R8) -DO I = 1, N - ! Skip repeated vertices. - IF (I .EQ. SIMPS(1,MI)) CYCLE - ! Check the diameter of the resulting circumsphere. - CURRRAD = DNRM2(D, PTS(:,I)-PTS(:,SIMPS(1,MI)), 1) - IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(2,MI) = I; END IF -END DO -IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. - IERR(MI) = 30; RETURN; END IF -! Set up the first row of the linear system. -AT(:,1) = PTS(:,SIMPS(2,MI)) - PTS(:,SIMPS(1,MI)) -B(1) = DDOT(D, AT(:,1), 1, AT(:,1), 1) / 2.0_R8 -! Loop to collect the remaining D-1 vertices for the first simplex. -DO I = 2, D - ! For numerical stability, refactor A^T P = Q R for the next iteration. - LQ(:,1:I-1) = AT(:,1:I-1) - CALL DGEQP3(D, I-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 80; RETURN - END IF - ! Set the RHS to P^T B. - FORALL (ITMP = 1:I-1) X(ITMP) = B(IPIV(ITMP)) - ! Solve R^T Q^T X = P^T B for Q^T X, and save for later. - CALL DTRSM('L', 'U', 'T', 'N', I-1, 1, 1.0_R8, LQ, D, X, D) - ! Make a copy for computing the current center. - CENTER(1:I-1) = X(1:I-1) - CENTER(I:D) = 0.0_R8 - ! Apply Q from the left. - CALL DORMQR('L', 'N', D, 1, I-1, LQ, D, TAU, CENTER, D, WORK, & - LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 83; RETURN - END IF - CENTER = CENTER + PTS(:,SIMPS(1,MI)) - ! Re-initialize the radius for each iteration. - MINRAD = HUGE(0.0_R8) - ! Check each point P* in PTS. - DO J = 1, N - ! Check that this point is not already in the simplex. - IF (ANY(SIMPS(:,MI) .EQ. J)) CYCLE - ! If PTS(:,J) is more than twice MINRAD from CENTER, do a quick skip. - IF (DNRM2(D, CENTER - PTS(:,J), 1) > 2.0_R8 * MINRAD) CYCLE - ! Perform a rank-1 update to the current QR factorization of A^T by - ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI)) by Q^T and storing in the - ! final column of R. - LQ(:,I) = PTS(:,J) - PTS(:,SIMPS(1,MI)) - CALL DORMQR('L', 'T', D, 1, I-1, LQ(:,1:I-1), D, TAU, LQ(:,I), D, & - WORK, LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 83; RETURN - END IF - ! Implicitly apply the next Householder reflector. - LQ(I,I) = DNRM2(D+1-I, LQ(I:D,I), 1) - IF (LQ(I,I) < EPSL) THEN ! A is rank-deficient. - CYCLE ! If rank-deficient, skip this point. - END IF - ! Update the current radius by \| Q^T X \| = \| X \|. - WORK(1:I-1) = (LQ(1:I-1,I) / 2.0_R8) - X(1:I-1) - WORK(I) = LQ(I,I) / 2.0_R8 - X(I) = DDOT(I, LQ(1:I,I), 1, WORK(1:I), 1) / LQ(I,I) - CURRRAD = DNRM2(I, X(1:I), 1) - ! Compare the last component of Q^T X to the current minimum. - IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(I+1,MI) = J; END IF - END DO - ! Check that a point was found. If not, then all the points must lie in a - ! lower dimensional linear manifold (error case). - IF (SIMPS(I+1,MI) .EQ. 0) THEN; IERR(MI) = 31; RETURN; END IF - ! If all operations were successful, add the best P* to the linear system. - AT(:,I) = PTS(:,SIMPS(I+1,MI)) - PTS(:,SIMPS(1,MI)) - B(I) = DDOT(D, AT(:,I), 1, AT(:,I), 1) / 2.0_R8 -END DO -IERR(MI) = 0 ! Set error flag to 'success' for a normal return. -RETURN -END SUBROUTINE MAKEFIRSTSIMP - -SUBROUTINE MAKESIMPLEX() -! Given a Delaunay facet F whose containing hyperplane does not contain -! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' -! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F -! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the -! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly -! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing -! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices -! P_1, P_2, ..., P_D, P*. Then -! -! X = CENTER - P_1 -! -! is given by the solution to the nonsingular linear system -! -! A X = B where -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and -! B = [ /2, /2, ..., /2 ]^T. -! -! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the -! candidate P* that satisfies both of the following: -! -! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) -! must be on the same side of PLANE. -! -! 2) The circumball about CENTER must not contain any points in PTS in its -! interior (Delaunay property). -! -! The above are necessary and sufficient conditions for flipping the -! Delaunay simplex, given that F is indeed a Delaunay facet. -! -! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices -! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex -! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and -! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were -! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an -! extrapolation point (not a convex combination of points in PTS). - -! Compute the hyperplane PLANE. -CALL MAKEPLANE() -IF(IERR(MI) .NE. 0) RETURN ! Check for errors. -! Compute the sign for the side of PLANE containing Q(:,MI). -SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) -SIDE1 = SIGN(1.0_R8,SIDE1) -! Initialize the center, radius, and simplex. -SIMPS(D+1,MI) = 0 -CENTER(:) = 0.0_R8 -MINRAD = HUGE(0.0_R8) -! If D=1, just check for the closest point on SIDE1 of PTS(:,SIMPS(1,MI)). -IF (D .EQ. 1) THEN - ! Loop through all points P* in PTS. - DO I = 1, N - ! Check that P* is on the appropriate halfspace. - SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 - IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE - ! Check that P* is closer than the current solution. - IF (SIDE2 > MINRAD) CYCLE - ! Update the minimum distance and save the index I. - MINRAD = SIDE2 - SIMPS(2,MI) = I - END DO - IERR(MI) = 0 ! Reset the error flag to 'success' code. - ! Check for extrapolation condition. - IF(SIMPS(2,MI) .EQ. 0) RETURN - ! Add new point to the linear system. - AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) - B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 - RETURN -END IF -! Set the RHS to P^T B. -FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) -! Solve R^T Q^T X = P^T B for Q^T X. -CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) -! Loop through all points P* in PTS. -DO I = 1, N - ! Check that P* is inside the current ball. - IF (DNRM2(D, PTS(:,I) - CENTER(:), 1) > MINRAD) CYCLE ! If not, skip. - ! Check that P* is on the appropriate halfspace. - SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) - IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE ! If not, skip. - ! Perform a rank-1 update to the current QR factorization of A^T by - ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the - ! final column of R. - LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) - CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & - LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 83; RETURN - END IF - ! Update the last element of Q^T X. - WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) - WORK(D) = LQ(D,D) / 2.0_R8 - CENTER(1:D-1) = X(1:D-1) - CENTER(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) - ! Get the center by applying Q to the solution. - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER, D, WORK, LWORK, & - IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 83; RETURN - END IF - ! Update the new radius, center, and simplex. - MINRAD = DNRM2(D, CENTER, 1) - CENTER(:) = CENTER(:) + PTS(:,SIMPS(1,MI)) - SIMPS(D+1,MI) = I -END DO -IERR(MI) = 0 ! Reset the error flag to 'success' code. -! Check for extrapolation condition. -IF(SIMPS(D+1,MI) .EQ. 0) RETURN -! Add new point to the linear system. -AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) -B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 -RETURN -END SUBROUTINE MAKESIMPLEX - -SUBROUTINE MAKEPLANE() -! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed -! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. -! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal -! vector is any nonzero vector in ker A, where the matrix -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. -! -! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR -! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. -! Then the last column of Q is orthogonal to the range of A^T, and in ker A. -! -! Upon output, PLANE(1:D) contains the normal vector c and PLANE(D+1) -! contains \alpha defining the plane. Also, LQ, IPIV, and TAU define a QR -! factorizaton of the first D-1 columns of A^T. - -IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. - ! Compute the QR factorization. - IPIV=0 - LQ = AT - CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 80; RETURN - END IF - ! The nullspace is given by the last column of Q. - PLANE(1:D-1) = 0.0_R8 - PLANE(D) = 1.0_R8 - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & - LWORK, IERR(MI)) - IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. - IERR(MI) = 83; RETURN - END IF - ! Calculate the constant \alpha defining the plane. - PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) -ELSE ! Special case where D=1. - PLANE(1) = 1.0_R8 - PLANE(2) = PTS(1,SIMPS(1,MI)) -END IF -RETURN -END SUBROUTINE MAKEPLANE - -FUNCTION PTINSIMP() RESULT(TF) -! Determine if any interpolation points are in the current simplex, whose -! vertices P_1, P_2, ..., P_{D+1} are indexed by SIMPS(:,MI). These -! vertices determine a positive cone with generators V_I = P_{I+1} - P_1, -! I = 1, ..., D. For each interpolation point Q* in Q, Q* - P_1 can be -! expressed as a unique linear combination of the V_I. If all these linear -! weights are nonnegative and sum to less than or equal to 1.0, then Q* is -! in the simplex with vertices {P_I}_{I=1}^{D+1}. -! -! If any interpolation points in Q are contained in the simplex whose -! vertices are indexed by SIMPS(:,MI), then those points are marked as solved -! and the values of SIMPS and WEIGHTS are updated appropriately. On output, -! WEIGHTS(:,MI) contains the affine weights for producing Q(:,MI) as an -! affine combination of the points in PTS indexed by SIMPS(:,MI). If these -! weights are nonnegative, then PTINSIMP() returns TRUE. - -! Initialize the return value and local variables. -LOGICAL :: TF ! True/False value. -TF = .FALSE. - -! Compute the LU factorization of the matrix A^T, whose columns are -! P_{I+1} - P_1. -LQ = AT -CALL DGETRF(D, D, LQ, D, IPIV, IERR(MI)) -IF (IERR(MI) < 0) THEN ! LAPACK illegal input. - IERR(MI) = 81; RETURN -ELSE IF (IERR(MI) > 0) THEN ! Rank-deficiency detected. - IERR(MI) = 61; RETURN -END IF -! Solve A^T w = WORK to get the affine weights for Q(:,MI) or its projection. -WORK(1:D) = PROJ(:) - PTS(:,SIMPS(1,MI)) -CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(1:D), D, IERR(MI)) -IF (IERR(MI) < 0) THEN ! LAPACK illegal input. - IERR(MI) = 82; RETURN -END IF -WEIGHTS(2:D+1,MI) = WORK(1:D) -WEIGHTS(1,MI) = 1.0_R8 - SUM(WEIGHTS(2:D+1,MI)) -! Check if the weights for Q(:,MI) are nonnegative. -IF (ALL(WEIGHTS(:,MI) .GE. -EPSL)) TF = .TRUE. - -! Compute the affine weights for the rest of the interpolation points. -DO I = MI+1, M - ! Check that no solution has already been found. - IF (IERR(I) .NE. 40) CYCLE - ! Solve A^T w = WORK to get the affine weights for Q(:,I). - WORK(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) - CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(2:D+1), D, ITMP) - IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. - ! Check if the weights define a convex combination. - WORK(1) = 1.0_R8 - SUM(WORK(2:D+1)) - IF (ALL(WORK(1:D+1) .GE. -EPSL)) THEN - ! Copy the simplex indices and weights then flag as complete. - SIMPS(:,I) = SIMPS(:,MI) - WEIGHTS(:,I) = WORK(1:D+1) - IERR(I) = 0 - END IF -END DO -RETURN -END FUNCTION PTINSIMP - -SUBROUTINE PROJECT() -! Project a point outside the convex hull of the point set onto the convex hull -! by solving an inequality constrained least squares problem. The solution to -! the least squares problem gives the projection as a convex combination of the -! data points. The projection can then be computed by performing a matrix -! vector multiplication. - -! Allocate work arrays. -IF (.NOT. ALLOCATED(IWORK_DWNNLS)) THEN - ALLOCATE(IWORK_DWNNLS(D+1+N), STAT=IERR(MI)) - IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF -END IF -IF (.NOT. ALLOCATED(WORK_DWNNLS)) THEN - ALLOCATE(WORK_DWNNLS(D+1+N*5), STAT=IERR(MI)) - IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF -END IF -IF (.NOT. ALLOCATED(W_DWNNLS)) THEN - ALLOCATE(W_DWNNLS(D+1,N+1), STAT=IERR(MI)) - IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF -END IF -IF (.NOT. ALLOCATED(X_DWNNLS)) THEN - ALLOCATE(X_DWNNLS(N), STAT=IERR(MI)) - IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF -END IF - -! Initialize work array and settings values. -PRGOPT_DWNNLS(1) = 1.0_R8 -IWORK_DWNNLS(1) = D+1+5*N -IWORK_DWNNLS(2) = D+1+N -W_DWNNLS(1, :) = 1.0_R8 ! Set convexity (equality) constraint. -W_DWNNLS(2:D+1,1:N) = PTS(:,:) ! Copy data points. -W_DWNNLS(2:D+1,N+1) = PROJ(:) ! Copy extrapolation point. -! Compute the solution to the inequality constrained least squares problem to -! get the projection coefficients. -CALL DWNNLS(W_DWNNLS, D+1, 1, D, N, 0, PRGOPT_DWNNLS, X_DWNNLS, RNORML, & - IERR(MI), IWORK_DWNNLS, WORK_DWNNLS) -IF (IERR(MI) .EQ. 1) THEN ! Failure to converge. - IERR(MI) = 71; RETURN -ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. - IERR(MI) = 72; RETURN -END IF -! Zero all weights that are approximately zero and renormalize the sum. -WHERE (X_DWNNLS < EPSL) X_DWNNLS = 0.0_R8 -X_DWNNLS(:) = X_DWNNLS(:) / SUM(X_DWNNLS) -! Compute the actual projection via matrix vector multiplication. -CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) -RNORML = DNRM2(D, PROJ(:) - Q(:,MI), 1) -RETURN -END SUBROUTINE PROJECT - -SUBROUTINE RESCALE(MINDIST, DIAMETER, SCALE) -! Rescale and transform data to be centered at the origin with unit -! radius. This subroutine has O(n^2) complexity. -! -! On output, PTS and Q have been rescaled and shifted. All the data -! points in PTS are centered with unit radius, and the points in Q -! have been shifted and scaled in relation to PTS. -! -! MINDIST is a real number containing the (scaled) minimum distance -! between any two data points in PTS. -! -! DIAMETER is a real number containing the (scaled) diameter of the -! data set PTS. -! -! SCALE contains the real factor used to transform the data and -! interpolation points: scaled value = (original value - -! barycenter of data points)/SCALE. - -! Output arguments. -REAL(KIND=R8), INTENT(OUT) :: MINDIST, DIAMETER, SCALE - -! Local variables. -REAL(KIND=R8) :: PTS_CENTER(D) ! The center of the data points PTS. -REAL(KIND=R8) :: DISTANCE ! The current distance. - -! Initialize local values. -MINDIST = HUGE(0.0_R8) -DIAMETER = 0.0_R8 -SCALE = 0.0_R8 - -! Compute barycenter of all data points. -PTS_CENTER(:) = SUM(PTS(:,:), DIM=2)/REAL(N, KIND=R8) -! Center the points. -FORALL (I = 1:N) PTS(:,I) = PTS(:,I) - PTS_CENTER(:) -! Compute the scale factor (for unit radius). -DO I = 1, N ! Cycle through all points again. - DISTANCE = DNRM2(D, PTS(:,I), 1) ! Compute the distance from the center. - IF (DISTANCE > SCALE) THEN ! Compare to the current radius. - SCALE = DISTANCE - END IF -END DO -! Scale the points to unit radius. -PTS = PTS / SCALE -! Also transform Q similarly. -FORALL (I = 1:M) Q(:,I) = (Q(:,I) - PTS_CENTER(:)) / SCALE -! Compute the minimum and maximum distances. -IF (EXACTL) THEN - ! If exact error error checking is turned on, then compute the DIAMETER - ! and MINDIST values. - DO I = 1, N ! Cycle through all pairs of points. - DO J = I + 1, N - DISTANCE = DNRM2(D, PTS(:,I) - PTS(:,J), 1) ! Compute the distance. - IF (DISTANCE > DIAMETER) THEN ! Compare to the current diameter. - DIAMETER = DISTANCE - END IF - IF (DISTANCE < MINDIST) THEN ! Compare to the current minimum distance. - MINDIST = DISTANCE - END IF - END DO - END DO -ELSE - ! If exact error checking is turned off, then the diameter is approximately - ! 2.0 after rescaling and centering the points. The MINDIST is not computed. - DIAMETER = 2.0_R8 - MINDIST = 1.0_R8 -END IF -RETURN -END SUBROUTINE RESCALE - -END SUBROUTINE DELAUNAYSPARSES - - -SUBROUTINE DELAUNAYSPARSEP( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EXACT, & - PMODE ) -! This is a parallel implementation of an algorithm for efficiently performing -! interpolation in R^D via the Delaunay triangulation. The algorithm is fully -! described and analyzed in -! -! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. -! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate -! interpolation in arbitrary dimension via the Delaunay triangulation. In -! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, -! USA. Article 12, 8 pages. -! -! -! On input: -! -! D is the dimension of the space for PTS and Q. -! -! N is the number of data points in PTS. -! -! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the -! coordinates of a single data point in R^D. -! -! M is the number of interpolation points in Q. -! -! Q(1:D,1:M) is a real valued matrix with M columns, each containing the -! coordinates of a single interpolation point in R^D. -! -! -! On output: -! -! PTS and Q have been rescaled and shifted. All the data points in PTS -! are now contained in the unit hyperball in R^D, and the points in Q -! have been shifted and scaled accordingly in relation to PTS. -! -! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns -! in PTS) for the D+1 vertices of the Delaunay simplex containing each -! interpolation point in Q. -! -! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each -! point in Q as a convex combination of the D+1 corresponding vertices -! in SIMPS. -! -! IERR(1:M) contains integer valued error flags associated with the -! computation of each of the M interpolation points in Q. The error -! codes are: -! -! 00 : Succesful interpolation. -! 01 : Succesful extrapolation (up to the allowed extrapolation distance). -! 02 : This point was outside the allowed extrapolation distance; the -! corresponding entries in SIMPS and WEIGHTS contain zero values. -! -! 10 : The dimension D must be positive. -! 11 : Too few data points to construct a triangulation (i.e., N < D+1). -! 12 : No interpolation points given (i.e., M < 1). -! 13 : The first dimension of PTS does not agree with the dimension D. -! 14 : The second dimension of PTS does not agree with the number of points N. -! 15 : The first dimension of Q does not agree with the dimension D. -! 16 : The second dimension of Q does not agree with the number of -! interpolation points M. -! 17 : The first dimension of the output array SIMPS does not match the number -! of vertices needed for a D-simplex (D+1). -! 18 : The second dimension of the output array SIMPS does not match the -! number of interpolation points M. -! 19 : The first dimension of the output array WEIGHTS does not match the -! number of vertices for a a D-simplex (D+1). -! 20 : The second dimension of the output array WEIGHTS does not match the -! number of interpolation points M. -! 21 : The size of the error array IERR does not match the number of -! interpolation points M. -! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. -! 23 : The first dimension of INTERP_IN does not match the first -! dimension of INTERP_OUT. -! 24 : The second dimension of INTERP_IN does not match the number of -! data points PTS. -! 25 : The second dimension of INTERP_OUT does not match the number of -! interpolation points M. -! 26 : The budget supplied in IBUDGET does not contain a positive -! integer. -! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. -! 28 : The size of the RNORM output array does not match the number of -! interpolation points M. -! -! 30 : Two or more points in the data set PTS are too close together with -! respect to the working precision (EPS), which would result in a -! numerically degenerate simplex. -! 31 : All the data points in PTS lie in some lower dimensional linear -! manifold (up to the working precision), and no valid triangulation -! exists. -! 40 : An error caused DELAUNAYSPARSEP to terminate before this value could -! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may -! contain garbage values. -! -! 50 : A memory allocation error occurred while allocating the work array -! WORK. -! -! 60 : The budget was exceeded before the algorithm converged on this -! value. If the dimension is high, try increasing IBUDGET. This -! error can also be caused by a working precision EPS that is too -! small for the conditioning of the problem. -! -! 61 : A value that was judged appropriate later caused LAPACK to encounter a -! singularity. Try increasing the value of EPS. -! -! 70 : Allocation error for the extrapolation work arrays. -! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection -! of an extrapolation point onto the convex hull. -! 72 : The SLATEC subroutine DWNNLS has reported a usage error. -! -! The errors 72, 80--83 should never occur, and likely indicate a -! compiler bug or hardware failure. -! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. -! 81 : The LAPACK subroutine DGETRF has reported an illegal value. -! 82 : The LAPACK subroutine DGETRS has reported an illegal value. -! 83 : The LAPACK subroutine DORMQR has reported an illegal value. -! -! 90 : The value of PMODE is not valid. -! -! -! Optional arguments: -! -! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of -! the data points in PTS on input. The first dimension of INTERP_IN is -! inferred to be the dimension of these response vectors, and the -! second dimension must match N. If present, the response values will -! be computed for each interpolation point in Q, and stored in INTERP_OUT, -! which therefore must also be present. If both INTERP_IN and INTERP_OUT -! are omitted, only the containing simplices and convex combination -! weights are returned. -! -! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each -! interpolation point in Q on output. The first dimension of INTERP_OU -! must match the first dimension of INTERP_IN, and the second dimension -! must match M. If present, the response values at each interpolation -! point are computed as a convex combination of the response values -! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing -! that interpolation point. Therefore, if INTERP_OUT is present, then -! INTERP_IN must also be present. If both are omitted, only the -! simplices and convex combination weights are returned. -! -! EPS contains the real working precision for the problem on input. By -! default, EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff -! for the machine. In general, any values that differ by less than EPS -! are judged as equal, and any weights that are greater than -EPS are -! judged as nonnegative. EPS cannot take a value less than the default -! value of \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, -! the default value will be used instead automatically. -! -! EXTRAP contains the real maximum extrapolation distance (relative to the -! diameter of PTS) on input. Interpolation at a point outside the convex -! hull of PTS is done by projecting that point onto the convex hull, and -! then doing normal Delaunay interpolation at that projection. -! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) -! units outside the convex hull of PTS will not be done and an error code -! of 2 will be returned. Note that computing the projection can be -! expensive. Setting EXTRAP=0 will cause all extrapolation points to be -! ignored without ever computing a projection. By default, EXTRAP=0.1 -! (extrapolate by up to 10% of the diameter of PTS). -! -! RNORM(1:M) contains the real unscaled projection (2-norm) distances from -! any projection computations on output. If not present, these distances -! are still computed for each extrapolation point, but are never returned. -! -! IBUDGET on input contains the integer budget for performing flips while -! iterating toward the simplex containing each interpolation point in Q. -! This prevents DELAUNAYSPARSEP from falling into an infinite loop when -! an inappropriate value of EPS is given with respect to the problem -! conditioning. By default, IBUDGET=50000. However, for extremely -! high-dimensional problems and pathological inputs, the default value -! may be insufficient. -! -! CHAIN is a logical input argument that determines whether a new first -! simplex should be constructed for each interpolation point -! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." -! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not -! recommended, unless the size of the triangulation is relatively small -! or the interpolation points are known to be tightly clustered. -! -! EXACT is a logical input argument that determines whether the exact -! diameter should be computed and whether a check for duplicate data -! points should be performed in advance. When EXACT=.FALSE., the -! diameter of PTS is approximated by twice the distance from the -! barycenter of PTS to the farthest point in PTS, and no check is -! done to find the closest pair of points, which could result in hard -! to find bugs later on. When EXACT=.TRUE., the exact diameter is -! computed and an error is returned whenever PTS contains duplicate -! values up to the precision EPS. By default EXACT=.TRUE., but setting -! EXACT=.FALSE. could result in significant speedup when N is large. -! It is strongly recommended that most users leave EXACT=.TRUE., as -! setting EXACT=.FALSE. could result in input errors that are difficult -! to identify. Also, the diameter approximation could be wrong by up to -! a factor of two. -! -! PMODE is an integer specifying the level of parallelism to be exploited. -! If PMODE = 1, then parallelism is exploited at the level of the loop -! over all interpolation points (Level 1 parallelism). -! If PMODE = 2, then parallelism is exploited at the level of the loops -! over data points when constructing/flipping simplices (Level 2 -! parallelism). -! If PMODE = 3, then parallelism is exploited at both levels. Note: this -! implies that the total number of threads active at any time could be up -! to OMP_NUM_THREADS^2. -! By default, PMODE is set to 1 if there is more than 1 interpolation -! point and 2 otherwise. -! -! -! Subroutines and functions directly referenced from BLAS are -! DDOT, DGEMV, DNRM2, DTRSM, -! and from LAPACK are -! DGEQP3, DGETRF, DGETRS, DORMQR. -! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its -! SLATEC dependencies have been slightly edited to comply with the Fortran -! 2008 standard, with all print statements and references to stderr being -! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 -! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS -! Algorithm 777) is used for the real data type. The REAL_PRECISION module, -! DELAUNAYSPARSEP, and DWNNLS and its dependencies comply with the Fortran -! 2008 standard. -! -! Primary Author: Tyler H. Chang -! Last Update: March, 2020 -! -USE REAL_PRECISION, ONLY : R8 -IMPLICIT NONE - -! Input arguments. -INTEGER, INTENT(IN) :: D, N -REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) ! Rescaled on output. -INTEGER, INTENT(IN) :: M -REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) ! Rescaled on output. -! Output arguments. -INTEGER, INTENT(OUT) :: SIMPS(:,:) -REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) -INTEGER, INTENT(OUT) :: IERR(:) -! Optional arguments. -REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) -REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) -REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP -REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) -INTEGER, INTENT(IN), OPTIONAL :: IBUDGET, PMODE -LOGICAL, INTENT(IN), OPTIONAL :: CHAIN -LOGICAL, INTENT(IN), OPTIONAL :: EXACT - -! Local copies of optional input arguments. -REAL(KIND=R8) :: EPSL, EXTRAPL -INTEGER :: IBUDGETL -LOGICAL :: CHAINL, EXACTL, PLVL1, PLVL2 - -! Local variables. -LOGICAL :: PTINSIMP ! Tells if Q(:,MI) is in SIMPS(:,MI). -INTEGER :: I, J, K ! Loop iteration variables. -INTEGER :: IEXTRAPS ! Extrapolation budget. -INTEGER :: IERR_PRIV ! Private copy of the error flag. -INTEGER :: ITMP, JTMP ! Temporary variables for swapping, looping, etc. -INTEGER :: LWORK ! Size of the work array. -INTEGER :: MI ! Index of current interpolation point. -INTEGER :: VERTEX_PRIV ! Private copy of next vertex to add. -REAL(KIND=R8) :: CURRRAD ! Radius of the current circumsphere. -REAL(KIND=R8) :: MINRAD ! Minimum circumsphere radius observed. -REAL(KIND=R8) :: MINRAD_PRIV ! Private copy of MINRAD. -REAL(KIND=R8) :: PTS_DIAM ! Scaled diameter of data set. -REAL(KIND=R8) :: PTS_SCALE ! Data scaling factor. -REAL(KIND=R8) :: RNORML ! Euclidean norm of the projection residual. -REAL(KIND=R8) :: SIDE1, SIDE2 ! Signs (+/-1) denoting sides of a facet. - -! Local arrays, requiring O(d^2) additional memory. -INTEGER :: IPIV(D) ! Pivot indices. -INTEGER :: SEED(D+1) ! Copy of the SEED simplex. Only used if CHAIN = .TRUE. -REAL(KIND=R8) :: AT(D,D) ! The transpose of A, the linear coefficient matrix. -REAL(KIND=R8) :: B(D) ! The RHS of a linear system. -REAL(KIND=R8) :: CENTER(D) ! The circumcenter of a simplex. -REAL(KIND=R8) :: CENTER_PRIV(D) ! Private copy of CENTER. -REAL(KIND=R8) :: LQ(D,D) ! Holds LU or QR factorization of AT. -REAL(KIND=R8) :: PLANE(D+1) ! The hyperplane containing a facet. -REAL(KIND=R8) :: PRGOPT_DWNNLS(1) ! Options array for DWNNLS. -REAL(KIND=R8) :: PROJ(D) ! The projection of the current iterate. -REAL(KIND=R8) :: TAU(D) ! Householder reflector constants. -REAL(KIND=R8) :: X(D) ! The solution to a linear system. - -! Extrapolation work arrays are only allocated if DWNNLS is called. -INTEGER, ALLOCATABLE :: IWORK_DWNNLS(:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: W_DWNNLS(:,:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: WORK(:) ! Allocated with size LWORK. -REAL(KIND=R8), ALLOCATABLE :: WORK_DWNNLS(:) ! Only for DWNNLS. -REAL(KIND=R8), ALLOCATABLE :: X_DWNNLS(:) ! Only for DWNNLS. - -! External functions and subroutines. -REAL(KIND=R8), EXTERNAL :: DDOT ! Inner product (BLAS). -REAL(KIND=R8), EXTERNAL :: DNRM2 ! Euclidean norm (BLAS). -EXTERNAL :: DGEMV ! General matrix vector multiply (BLAS) -EXTERNAL :: DGEQP3 ! Perform a QR factorization with column pivoting (LAPACK). -EXTERNAL :: DGETRF ! Perform a LU factorization with partial pivoting (LAPACK). -EXTERNAL :: DGETRS ! Use the output of DGETRF to solve a linear system (LAPACK). -EXTERNAL :: DORMQR ! Apply householder reflectors to a matrix (LAPACK). -EXTERNAL :: DTRSM ! Perform a triangular solve (BLAS). -EXTERNAL :: DWNNLS ! Solve an inequality constrained least squares problem - ! (SLATEC). - -! Check for input size and dimension errors. -IF (D < 1) THEN ! The dimension must satisfy D > 0. - IERR(:) = 10; RETURN; END IF -IF (N < D+1) THEN ! Must have at least D+1 data points. - IERR(:) = 11; RETURN; END IF -IF (M < 1) THEN ! Must have at least one interpolation point. - IERR(:) = 12; RETURN; END IF -IF (SIZE(PTS,1) .NE. D) THEN ! Dimension of PTS array should match. - IERR(:) = 13; RETURN; END IF -IF (SIZE(PTS,2) .NE. N) THEN ! Number of data points should match. - IERR(:) = 14; RETURN; END IF -IF (SIZE(Q,1) .NE. D) THEN ! Dimension of Q should match. - IERR(:) = 15; RETURN; END IF -IF (SIZE(Q,2) .NE. M) THEN ! Number of interpolation points should match. - IERR(:) = 16; RETURN; END IF -IF (SIZE(SIMPS,1) .NE. D+1) THEN ! Need space for D+1 vertices per simplex. - IERR(:) = 17; RETURN; END IF -IF (SIZE(SIMPS,2) .NE. M) THEN ! There will be M output simplices. - IERR(:) = 18; RETURN; END IF -IF (SIZE(WEIGHTS,1) .NE. D+1) THEN ! There will be D+1 weights per simplex. - IERR(:) = 19; RETURN; END IF -IF (SIZE(WEIGHTS,2) .NE. M) THEN ! One vector of weights per simplex. - IERR(:) = 20; RETURN; END IF -IF (SIZE(IERR) .NE. M) THEN ! An error flag for each interpolation point. - IERR(:) = 21; RETURN; END IF - -! Check for optional arguments. -IF (PRESENT(INTERP_IN) .NEQV. PRESENT(INTERP_OUT)) THEN - IERR(:) = 22; RETURN; END IF -IF (PRESENT(INTERP_IN)) THEN ! Sizes must agree. - IF (SIZE(INTERP_IN,1) .NE. SIZE(INTERP_OUT,1)) THEN - IERR(:) = 23 ; RETURN; END IF - IF(SIZE(INTERP_IN,2) .NE. N) THEN - IERR(:) = 24; RETURN; END IF - IF (SIZE(INTERP_OUT,2) .NE. M) THEN - IERR(:) = 25; RETURN; END IF - INTERP_OUT(:,:) = 0.0_R8 ! Initialize output to zeros. -END IF -EPSL = SQRT(EPSILON(0.0_R8)) ! Get the machine unit roundoff constant. -IF (PRESENT(EPS)) THEN - IF (EPSL < EPS) THEN ! If the given precision is too small, ignore it. - EPSL = EPS - END IF -END IF -IF (PRESENT(IBUDGET)) THEN - IBUDGETL = IBUDGET ! Use the given budget if present. - IF (IBUDGETL < 1) THEN - IERR(:) = 26; RETURN; END IF -ELSE - IBUDGETL = 50000 ! Default value for budget. -END IF -IF (PRESENT(EXTRAP)) THEN - EXTRAPL = EXTRAP - IF (EXTRAPL < 0) THEN ! Check that the extrapolation distance is legal. - IERR(:) = 27; RETURN; END IF -ELSE - EXTRAPL = 0.1_R8 ! Default extrapolation distance (for normalized points). -END IF -IF (PRESENT(RNORM)) THEN - IF (SIZE(RNORM,1) .NE. M) THEN ! The length of the array must match. - IERR(:) = 28; RETURN; END IF - RNORM(:) = 0.0_R8 ! Initialize output to zeros. -END IF -IF (PRESENT(CHAIN)) THEN - CHAINL = CHAIN ! Turn chaining on, if necessarry. - SEED(:) = 0 ! Initialize SEED in case it is needed. -ELSE - CHAINL = .FALSE. -END IF -IF (PRESENT(EXACT)) THEN - EXACTL = EXACT ! Set error checking and exact diameter computations. -ELSE - EXACTL = .TRUE. -END IF -! Set the PMODE. -PLVL1 = .FALSE. -PLVL2 = .FALSE. -IF (PRESENT(PMODE)) THEN ! Check PMODE for legal values. - IF (PMODE .EQ. 1) THEN - PLVL1 = .TRUE. - ELSE IF (PMODE .EQ. 2) THEN - PLVL2 = .TRUE. - ELSE IF (PMODE .EQ. 3) THEN - PLVL1 = .TRUE.; PLVL2 = .TRUE. - ELSE - IERR(:) = 90; RETURN - END IF -ELSE ! The default setting for PMODE is level 1 parallelism if M > 1. - IF (M > 1) THEN - PLVL1 = .TRUE. - ELSE - PLVL2 = .TRUE. - END IF -END IF - -! Scale and center the data points and interpolation points. -CALL RESCALE(MINRAD, PTS_DIAM, PTS_SCALE) -IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. - IERR(:) = 30; RETURN; END IF - -! Query DGEQP3 for optimal work array size (LWORK). -LWORK = -1 -CALL DGEQP3(D,D,LQ,D,IPIV,TAU,B,LWORK,IERR(1)) -LWORK = INT(B(1)) ! Compute the optimal work array size. -ALLOCATE(WORK(LWORK), STAT=I) ! Allocate WORK to size LWORK. -IF (I .NE. 0) THEN ! Check for memory allocation errors. - IERR(:) = 50; RETURN; END IF - -! Initialize PRGOPT_DWNNLS in case of extrapolation. -PRGOPT_DWNNLS(1) = 1.0_R8 - -! Initialize all error codes to "TBD" values. -IERR(:) = 40 - -! Begin level 1 parallel region (over all interpolation points in Q). -!$OMP PARALLEL & -! -! The FIRSTPRIVATE list specifies initialized variables, of which each -! thread has a private copy. -!$OMP& FIRSTPRIVATE(SEED), & -! -! The PRIVATE list specifies uninitialized variables, of which each -! thread has a private copy. -!$OMP& PRIVATE(I, J, K, IEXTRAPS, ITMP, JTMP, CURRRAD, MI, MINRAD, & -!$OMP& RNORML, SIDE1, SIDE2, IERR_PRIV, VERTEX_PRIV, MINRAD_PRIV, & -!$OMP& PTINSIMP, IPIV, AT, B, CENTER, CENTER_PRIV, LQ, PLANE, & -!$OMP& PROJ, TAU, WORK, X, IWORK_DWNNLS, W_DWNNLS, WORK_DWNNLS, & -!$OMP& X_DWNNLS), & -! -! Any variables not explicitly listed above receive the SHARED scope -! by default and are visible across all threads. -!$OMP& DEFAULT(SHARED), & -! -!$OMP& IF(PLVL1) -!$OMP DO SCHEDULE(DYNAMIC) -OUTER : DO MI = 1, M - !$OMP CRITICAL(CHECK_IERR) - ! Check if this interpolation point was already found. - IF (IERR(MI) .EQ. 40) THEN - IERR(MI) = 0 - IERR_PRIV = 0 - ELSE - IERR_PRIV = -1 - END IF - !$OMP END CRITICAL(CHECK_IERR) - IF(IERR_PRIV .EQ. -1) CYCLE OUTER - - ! Initialize the projection and reset the residual. - PROJ(:) = Q(:,MI) - RNORML = 0.0_R8 - - ! Check if extrapolation is enabled. - IF (EXTRAPL < EPSL) THEN - IEXTRAPS = -1 ! If not, set the extrapolation budget negative. - ELSE - IEXTRAPS = 1 ! Allow for exactly one projection for this point. - END IF - - ! If there is no useable seed or if chaining is turned off, then make a new - ! simplex. - IF( (.NOT. CHAINL) .OR. SEED(1) .EQ. 0) THEN -! CALL MAKEFIRSTSIMP(); IF(IERR_PRIV .NE. 0) CYCLE OUTER - - -!****************************************************************************** -! Due to OpenMP's handling of variable scope, the parallel implementation of -! the subroutine MAKEFIRSTSIMP() has been in-lined here. -! -! SUBROUTINE MAKEFIRSTSIMP() -! -! Iteratively construct the first simplex by choosing points that -! minimize the radius of the smallest circumball. Let P_1, P_2, ..., P_K -! denote the current list of vertices for the simplex. Let P* denote the -! candidate vertex to be added to the simplex. Let CENTER denote the -! circumcenter of the simplex. Then -! -! X = CENTER - P_1 -! -! is given by the minimum norm solution to the underdetermined linear system -! -! A X = B, where -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_K - P_1, P* - P_1 ] and -! B = [ /2, /2, ..., /2 ]^T. -! -! Then the radius of the smallest circumsphere is CURRRAD = \| X \|, -! and the next vertex is given by P_{K+1} = argmin_{P*} CURRRAD, where P* -! ranges over points in PTS that are not already a vertex of the simplex. -! -! On output, this subroutine fully populates the matrix A^T and vector B, -! and fills SIMPS(:,MI) with the indices of a valid Delaunay simplex. - -! Initialize simplex and shared variables. -SIMPS(:,MI) = 0 -MINRAD_PRIV = HUGE(0.0_R8) -MINRAD = HUGE(0.0_R8) - -! Below is a Level 2 parallel region over N points in PTS to find the -! first and second vertices SIMPS(1,MI) and SIMPS(2,MI). -!$OMP PARALLEL & -! -! The FIRSTPRIVATE list specifies initialized variables, of which each -! thread has a private copy. -!$OMP& FIRSTPRIVATE(MINRAD_PRIV), & -! -! The PRIVATE list specifies uninitialized variables, of which each -! thread has a private copy. -!$OMP& PRIVATE(I, CURRRAD, VERTEX_PRIV), & -! -! Any variables not explicitly listed above receive the SHARED scope -! by default and are visible across all threads. -!$OMP& DEFAULT(SHARED), & -! -!$OMP& IF(PLVL2) -! Find the first point, i.e., the closest point to Q(:,MI). -!$OMP DO SCHEDULE(STATIC) -DO I = 1, N - ! Check the distance to Q(:,MI) - CURRRAD = DNRM2(D, PTS(:,I) - PROJ(:), 1) - IF (CURRRAD < MINRAD_PRIV) THEN - MINRAD_PRIV = CURRRAD; VERTEX_PRIV = I; - END IF -END DO -!$OMP END DO -!$OMP CRITICAL(REDUC_1) -IF (MINRAD_PRIV < MINRAD) THEN - MINRAD = MINRAD_PRIV; SIMPS(1,MI) = VERTEX_PRIV; -END IF -!$OMP END CRITICAL(REDUC_1) -! Find the second point, i.e., the closest point to PTS(:,SIMPS(1,MI)). -MINRAD_PRIV = HUGE(0.0_R8) -!$OMP BARRIER -!$OMP SINGLE -MINRAD = HUGE(0.0_R8) -!$OMP END SINGLE -!$OMP DO SCHEDULE(STATIC) -DO I = 1, N - ! Skip repeated vertices. - IF (I .EQ. SIMPS(1,MI)) CYCLE - ! Check the diameter of the resulting circumsphere. - CURRRAD = DNRM2(D, PTS(:,I)-PTS(:,SIMPS(1,MI)), 1) - IF (CURRRAD < MINRAD_PRIV) THEN - MINRAD_PRIV = CURRRAD; VERTEX_PRIV = I - END IF -END DO -!$OMP END DO -!$OMP CRITICAL(REDUC_2) -IF (MINRAD_PRIV < MINRAD) THEN - MINRAD = MINRAD_PRIV; SIMPS(2,MI) = VERTEX_PRIV -END IF -!$OMP END CRITICAL(REDUC_2) -!$OMP END PARALLEL -! This is the end of the Level 2 parallel block. -IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. - IERR(MI) = 30; CYCLE OUTER; END IF - -! Set up the first row of the system A X = B. -AT(:,1) = PTS(:,SIMPS(2,MI)) - PTS(:,SIMPS(1,MI)) -B(1) = DDOT(D, AT(:,1), 1, AT(:,1), 1) / 2.0_R8 - -! Loop to collect the remaining D-1 vertices for the first simplex. -DO I = 2, D - ! Compute A^T P = Q R for the current matrix A^T. - LQ(:,1:I-1) = AT(:,1:I-1) - CALL DGEQP3(D, I-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 80 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Set the RHS to P^T B. - FORALL (ITMP = 1:I-1) X(ITMP) = B(IPIV(ITMP)) - ! Solve R^T Q^T X = P^T B for Q^T X, and save for later. - CALL DTRSM('L', 'U', 'T', 'N', I-1, 1, 1.0_R8, LQ, D, X, D) - ! Make a copy for computing the current center. - CENTER(1:I-1) = X(1:I-1) - CENTER(I:D) = 0.0_R8 - ! Apply Q from the left. - CALL DORMQR('L', 'N', D, 1, I-1, LQ, D, TAU, CENTER, D, WORK, & - LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 83 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - CENTER = CENTER + PTS(:,SIMPS(1,MI)) - ! Re-initialize the radius for each iteration. - MINRAD = HUGE(0.0_R8) - MINRAD_PRIV = HUGE(0.0_R8) - VERTEX_PRIV = 0 - - ! This is another Level 2 parallel block over N points in PTS. - !$OMP PARALLEL & - ! - ! The FIRSTPRIVATE list specifies initialized variables, of which each - ! thread has a private copy. - !$OMP& FIRSTPRIVATE(LQ, MINRAD_PRIV, VERTEX_PRIV, X), & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(J, CURRRAD, WORK), & - ! - ! The REDUCTION clause specifies a PRIVATE variable that will retain - ! some value (i.e., max, min, sum, etc.) upon output. - !$OMP& REDUCTION(MAX:IERR_PRIV), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& IF(PLVL2) - - ! Initialize the error flag. - IERR_PRIV = 0 - !$OMP DO SCHEDULE(STATIC) - DO J = 1, N - IF (IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. - ! Check that this point is not already in the simplex. - IF (ANY(SIMPS(:,MI) .EQ. J)) CYCLE - ! If PTS(:,J) is more than twice MINRAD_PRIV from CENTER, do a quick skip. - IF (DNRM2(D, CENTER - PTS(:,J), 1) > 2.0_R8 * MINRAD_PRIV) CYCLE - ! Perform a rank-1 update to the current QR factorization of A^T by - ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the - ! final column of R. - LQ(:,I) = PTS(:,J) - PTS(:,SIMPS(1,MI)) - CALL DORMQR('L', 'T', D, 1, I-1, LQ(:,1:I-1), D, TAU, LQ(:,I), D, & - WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - IERR_PRIV = 83; CYCLE - END IF - ! Implicitly apply the next Householder reflector. - LQ(I,I) = DNRM2(D+1-I, LQ(I:D,I), 1) - IF (LQ(I,I) < EPSL) THEN ! A is rank-deficient. - CYCLE ! If rank-deficient, skip this point. - END IF - ! Update the current radius by \| Q^T X \| = \| X \|. - WORK(1:I-1) = (LQ(1:I-1,I) / 2.0_R8) - X(1:I-1) - WORK(I) = LQ(I,I) / 2.0_R8 - X(I) = DDOT(I, LQ(1:I,I), 1, WORK(1:I), 1) / LQ(I,I) - CURRRAD = DNRM2(I, X(1:I), 1) - ! Compare the last component of Q^T X to the current minimum. - IF (CURRRAD < MINRAD_PRIV) THEN - MINRAD_PRIV = CURRRAD; VERTEX_PRIV = J - END IF - END DO - !$OMP END DO - !$OMP CRITICAL(REDUC_3) - IF (MINRAD_PRIV < MINRAD) THEN - MINRAD = MINRAD_PRIV; SIMPS(I+1,MI) = VERTEX_PRIV - END IF - !$OMP END CRITICAL(REDUC_3) - !$OMP END PARALLEL - ! End of Level 2 parallel block. - - ! Check the final error flag. - IF (IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = IERR_PRIV - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Check that a point was found. If not, then all the points must lie in a - ! lower dimensional linear manifold (error case). - IF (SIMPS(I+1,MI) .EQ. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 31 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! If all operations were successful, add the best P* to the linear system. - AT(:,I) = PTS(:,SIMPS(I+1,MI)) - PTS(:,SIMPS(1,MI)) - B(I) = DDOT(D, AT(:,I), 1, AT(:,I), 1) / 2.0_R8 -END DO -! RETURN -! END SUBROUTINE MAKEFIRSTSIMP -! This marks the end of the in-lined MAKEFIRSTSIMP() subroutine call. -!****************************************************************************** - - - ! Otherwise, use the seed. - ELSE - ! Copy the seed to the current simplex. - SIMPS(:,MI) = SEED(:) - ! Rebuild the linear system. - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - - ! Inner loop searching for a simplex containing the point Q(:,MI). - INNER : DO K = 1, IBUDGETL - - ! If chaining is on, save each good simplex as the next seed. - IF (CHAINL) SEED(:) = SIMPS(:,MI) - - -!****************************************************************************** -! Due to OpenMP's handling of variable scope, the parallel implementation of -! the subroutine PTINSIMP() has been in-lined here. -! -! FUNCTION PTINSIMP() RESULT(TF) -! Determine if any interpolation points are in the current simplex, whose -! vertices (P_1, P_2, ..., P_{D+1}) are indexed by SIMPS(:,MI). These -! vertices determine a positive cone with generators V_I = P_{I+1} - P_1, -! I = 1, ..., D. For each interpolation point Q* in Q, Q* - P_1 can be -! expressed as a unique linear combination of the V_I. If all these linear -! weights are nonnegative and sum to less than or equal to 1.0, then Q* is -! in the simplex with vertices {P_I}_{I=1}^{D+1}. -! -! If any interpolation points in Q are contained in the simplex whose -! vertices are indexed by SIMPS(:,MI), then those points are marked as solved -! and the values of SIMPS and WEIGHTS are updated appropriately. On output, -! WEIGHTS(:,MI) contains the affine weights for producing Q(:,MI) as an -! affine combination of the points in PTS indexed by SIMPS(:,MI). If these -! weights are nonnegative, then PTINSIMP() returns TRUE. - -! Initialize the return value and local variables. -PTINSIMP = .FALSE. - -! Compute the LU factorization of the matrix A^T, whose columns are -! P_{I+1} - P_1. -LQ = AT -CALL DGETRF(D, D, LQ, D, IPIV, IERR_PRIV) -IF (IERR_PRIV < 0) THEN ! LAPACK illegal input. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 81 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER -ELSE IF (IERR_PRIV > 0) THEN ! Rank-deficiency detected. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 61 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER -END IF -! Solve A^T w = WORK to get the affine weights for Q(:,MI) or its projection. -WORK(1:D) = PROJ(:) - PTS(:,SIMPS(1,MI)) -CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(1:D), D, IERR_PRIV) -IF (IERR_PRIV < 0) THEN ! LAPACK illegal input. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 82 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER -END IF -WEIGHTS(2:D+1,MI) = WORK(1:D) -WEIGHTS(1,MI) = 1.0_R8 - SUM(WEIGHTS(2:D+1,MI)) -! Check if the weights for Q(:,MI) are nonnegative. -IF (ALL(WEIGHTS(:,MI) .GE. -EPSL)) PTINSIMP = .TRUE. - -! If Level 1 parallelism is active, do not parallelize this loop. -IF (PLVL1) THEN - ! Loop over all remaining unsolved interoplation points. Uses PLANE(:) - ! as a work array. - DO I = MI+1, M - ! Check that no solution has already been found. - !$OMP CRITICAL(CHECK_IERR) - ITMP = IERR(I) - !$OMP END CRITICAL(CHECK_IERR) - IF (ITMP .NE. 40) CYCLE - ! Solve A^T w = PLANE to get the affine weights for Q(:,I). - PLANE(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) - CALL DGETRS('N', D, 1, LQ, D, IPIV, PLANE(2:D+1), D, ITMP) - IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. - ! Check if the weights define a convex combination. - PLANE(1) = 1.0_R8 - SUM(PLANE(2:D+1)) - IF (ALL(PLANE(1:D+1) .GE. -EPSL)) THEN - !$OMP CRITICAL(CHECK_IERR) - IF(IERR(I) .EQ. 40) THEN - ! Copy the simplex indices and weights then flag as complete. - SIMPS(:,I) = SIMPS(:,MI) - WEIGHTS(:,I) = PLANE(1:D+1) - IERR(I) = 0 - END IF - !$OMP END CRITICAL(CHECK_IERR) - END IF - END DO -! If Level 1 parallelism is not active, there will be no conflicts for -! parallelizing this loop. -ELSE - ! Level 2 parallel block over all remaining unsolved interoplation - ! points. Uses PLANE(:) as a work array. - !$OMP PARALLEL DO & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(I, PLANE, ITMP), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& SCHEDULE(STATIC), & - !$OMP& IF(PLVL2) - DO I = MI+1, M - ! Check that no solution has already been found. - IF (IERR(I) .NE. 40) CYCLE - ! Solve A^T w = PLANE to get the affine weights for Q(:,I). - PLANE(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) - CALL DGETRS('N', D, 1, LQ, D, IPIV, PLANE(2:D+1), D, ITMP) - IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. - ! Check if the weights define a convex combination. - PLANE(1) = 1.0_R8 - SUM(PLANE(2:D+1)) - IF (ALL(PLANE(1:D+1) .GE. -EPSL)) THEN - ! Copy the simplex indices and weights then flag as complete. - SIMPS(:,I) = SIMPS(:,MI) - WEIGHTS(:,I) = PLANE(1:D+1) - IERR(I) = 0 - END IF - END DO - !$OMP END PARALLEL DO -END IF -! End of Level 2 parallel block. -! RETURN -! END FUNCTION PTINSIMP -! This marks the end of the in-lined PTINSIMP() subroutine call. -!****************************************************************************** - - - ! Check if the current simplex contains Q(:,MI). - IF (PTINSIMP) EXIT INNER - - ! Swap out the least weighted vertex, but save its value in case it - ! needs to be restored later. - JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) - ITMP = SIMPS(JTMP,MI) - SIMPS(JTMP,MI) = SIMPS(D+1,MI) - - ! If the least weighted vertex (index JTMP) is not the first vertex, - ! then just drop row (JTMP-1) from the linear system (corresponding - ! to column (JTMP-1) of A^T). - IF(JTMP .NE. 1) THEN - AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) - ! However, if JTMP = 1, then both A^T and B must be reconstructed. - ELSE - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - - ! Compute the next simplex (do one flip). -! CALL MAKESIMPLEX(); IF (IERR_PRIV .NE. 0) CYCLE OUTER - - -!****************************************************************************** -! Due to OpenMP's handling of variable scope, the parallel implementation of -! the subroutine MAKESIMPLEX() has been in-lined here. -! -! SUBROUTINE MAKESIMPLEX() -! Given a Delaunay facet F whose containing hyperplane does not contain -! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' -! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F -! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the -! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly -! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing -! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices -! P_1, P_2, ..., P_D, P*. Then -! -! X = CENTER - P_1 -! -! is given by the solution to the nonsingular linear system -! -! A X = B where -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and -! B = [ /2, /2, ..., /2 ]^T. -! -! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the -! candidate P* that satisfies both of the following: -! -! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) -! must be on the same side of PLANE. -! -! 2) The circumball about CENTER must not contain any points in PTS in its -! interior (Delaunay property). -! -! The above are necessary and sufficient conditions for flipping the -! Delaunay simplex, given that F is indeed a Delaunay facet. -! -! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices -! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex -! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and -! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were -! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an -! extrapolation point (not a convex combination of points in PTS). - -! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed -! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. -! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal -! vector is any nonzero vector in ker A, where the matrix -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. -! -! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR -! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. -! Then the last column of Q is orthogonal to the range of A^T, and in ker A. -IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. - ! Compute the QR factorization. - IPIV=0 - LQ = AT - CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 80 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! The nullspace is given by the last column of Q. - PLANE(1:D-1) = 0.0_R8 - PLANE(D) = 1.0_R8 - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & - LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 83 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Calculate the constant \alpha defining the plane. - PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) - ! Compute the sign for the side of PLANE containing Q(:,MI). - SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) - SIDE1 = SIGN(1.0_R8,SIDE1) - - ! Set the RHS to P^T B. - FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) - ! Solve R^T Q^T X = P^T B for Q^T X. - CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) - - ! Initialize the center, radius, simplex, and OpenMP variabls. - SIMPS(D+1,MI) = 0 - CENTER(:) = 0.0_R8 - CENTER_PRIV(:) = 0.0_R8 - MINRAD = HUGE(0.0_R8) - MINRAD_PRIV = HUGE(0.0_R8) - VERTEX_PRIV = 0 - - ! Begin Level 2 parallel loop over N points in PTS. - !$OMP PARALLEL & - ! - ! The FIRSTPRIVATE list specifies initialized variables, of which each - ! thread has a private copy. - !$OMP& FIRSTPRIVATE(CENTER_PRIV, LQ, MINRAD_PRIV, VERTEX_PRIV), & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(I, SIDE2, WORK), & - ! - ! The REDUCTION clause specifies a PRIVATE variable that will retain - ! some value (i.e., max, min, sum, etc.) upon output. - !$OMP& REDUCTION(MAX:IERR_PRIV), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& IF(PLVL2) - - ! Initialize the error flag. - IERR_PRIV = 0 - !$OMP DO SCHEDULE(STATIC) - DO I = 1, N - IF(IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. - ! Check that P* is inside the current ball. - IF (DNRM2(D, PTS(:,I) - CENTER_PRIV(:), 1) > MINRAD_PRIV) CYCLE - ! Check that P* is on the appropriate halfspace. - SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) - IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE - ! Perform a rank-1 update to the current QR factorization of A^T by - ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the - ! final column of R. - LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) - CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & - LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - IERR_PRIV = 83; CYCLE - END IF - ! Update the last element of Q^T X. - WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) - WORK(D) = LQ(D,D) / 2.0_R8 - CENTER_PRIV(1:D-1) = X(1:D-1) - CENTER_PRIV(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) - ! Get the center by applying Q to the solution. - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER_PRIV, D, & - WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - IERR_PRIV = 83; CYCLE - END IF - ! Update the new radius, center, and simplex. - MINRAD_PRIV = DNRM2(D, CENTER_PRIV, 1) - CENTER_PRIV(:) = CENTER_PRIV(:) + PTS(:,SIMPS(1,MI)) - VERTEX_PRIV = I - END DO - !$OMP END DO - !$OMP CRITICAL(REDUC_4) - ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. - IF (VERTEX_PRIV .NE. 0) THEN - IF (DNRM2(D, PTS(:,VERTEX_PRIV) - CENTER(:), 1) < MINRAD) THEN - MINRAD = MINRAD_PRIV - CENTER(:) = CENTER_PRIV(:) - SIMPS(D+1,MI) = VERTEX_PRIV - END IF - END IF - !$OMP END CRITICAL(REDUC_4) - !$OMP END PARALLEL - ! End level 2 parallel region. - - ! Check for error flags. - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = IERR_PRIV - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Check for extrapolation condition. - IF(SIMPS(D+1,MI) .NE. 0) THEN - ! Add new point to the linear system. - AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - END IF -ELSE ! Special case where D=1. - PLANE(1) = 1.0_R8 - PLANE(2) = PTS(1,SIMPS(1,MI)) - SIDE1 = SIGN(1.0_R8, PROJ(1) - PLANE(2)) - ! Initialize the radius, simplex, and OpenMP variabls. - SIMPS(2,MI) = 0 - MINRAD = HUGE(0.0_R8) - MINRAD_PRIV = HUGE(0.0_R8) - VERTEX_PRIV = 0 - ! Begin Level 2 parallel loop over N points in PTS. - !$OMP PARALLEL & - ! - ! The FIRSTPRIVATE list specifies initialized variables, of which each - ! thread has a private copy. - !$OMP& FIRSTPRIVATE(MINRAD_PRIV, VERTEX_PRIV), & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(I, SIDE2), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& IF(PLVL2) - - !$OMP DO SCHEDULE(STATIC) - DO I = 1, N - ! Check that P* is on the appropriate halfspace. - SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 - IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE - ! Check that P* is closer than the current solution. - IF (SIDE2 > MINRAD) CYCLE - ! Update the minimum distance and save the index I. - MINRAD_PRIV = SIDE2 - VERTEX_PRIV = I - END DO - !$OMP END DO - !$OMP CRITICAL(REDUC_4) - ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. - IF (VERTEX_PRIV .NE. 0) THEN - IF (MINRAD_PRIV < MINRAD) THEN - MINRAD = MINRAD_PRIV - SIMPS(2,MI) = VERTEX_PRIV - END IF - END IF - !$OMP END CRITICAL(REDUC_4) - !$OMP END PARALLEL - ! Check for extrapolation condition. - IF(SIMPS(2,MI) .NE. 0) THEN - ! Add new point to the linear system. - AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) - B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 - END IF -END IF -! RETURN -! END SUBROUTINE MAKESIMPLEX -! End of in-lined code for MAKESIMPLEX(). -!****************************************************************************** - - - ! If no vertex was found, then this is an extrapolation point. - IF (SIMPS(D+1,MI) .EQ. 0) THEN - ! If extrapolation is not allowed (EXTRAP=0), do not proceed. - IF (IEXTRAPS < 0) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! Set the error flag and skip this point. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 2 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - - ! If extrapolation is allowed (EXTRAP>0), check the budget. - ELSE IF (IEXTRAPS .EQ. 0) THEN - ! A second projection has been attempted. This code is rarely - ! called, except in extreme cases involving nearly singular - ! simplices near the convex hull of P. - - ! Swap the weights to match the simplex indices, and zero the - ! most negative weight. - !$OMP CRITICAL(CHECK_IERR) - WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) - WEIGHTS(D+1,MI) = 0.0_R8 - !$OMP END CRITICAL(CHECK_IERR) - ! Loop through all the remaining facets from which Q(:,MI) is - ! visible, and attempt to flip across each one. - DO WHILE (SIMPS(D+1,MI) .EQ. 0) - ! Restore the previous simplex and linear system. - SIMPS(D+1,MI) = ITMP - AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - ! Find the next most negative weight. - JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) - ! Check if WEIGHTS(JTMP,MI) .GE. 0. - IF (WEIGHTS(JTMP,MI) .GE. -EPSL) THEN - ! There is no other direction to flip, so Q(:,MI) must be - ! within EPSL of the current simplex. - ! Project Q(:,MI) onto the current simplex. - - ! Since at least one projection has already been done, - ! the work arrays have already been allocated. - PRGOPT_DWNNLS(1) = 1.0_R8 - IWORK_DWNNLS(1) = 6*D + 6 - IWORK_DWNNLS(2) = 2*D + 2 - ! Set equality constraint. - W_DWNNLS(1,1:D+2) = 1.0_R8 - ! Populate LS coefficient matrix and RHS. - FORALL (I=1:D+1) W_DWNNLS(2:D+1,I) = PTS(:,SIMPS(I,MI)) - W_DWNNLS(2:D+1,D+2) = PROJ(:) - ! Project onto the current simplex. - CALL DWNNLS(W_DWNNLS, D+1, 1, D, D+1, 0, PRGOPT_DWNNLS, & - WEIGHTS(:,MI), WORK(1), IERR_PRIV, IWORK_DWNNLS, & - WORK_DWNNLS) - IF (IERR_PRIV .EQ. 1) THEN ! Failure to converge. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 71 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - ELSE IF (IERR_PRIV .EQ. 2) THEN ! Illegal input detected. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 72 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! A solution has been found; return it. - EXIT INNER - END IF - ! Otherwise, swap the vertices. - ITMP = SIMPS(JTMP,MI) - SIMPS(JTMP,MI) = SIMPS(D+1,MI) - ! Swap the weights to match, and zero the most negative weight. - !$OMP CRITICAL(CHECK_IERR) - WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) - WEIGHTS(D+1,MI) = 0.0_R8 - !$OMP END CRITICAL(CHECK_IERR) - ! If the least weighted vertex (index JTMP) is not the first vertex, - ! then just drop row (JTMP-1) from the linear system - ! (corresponding to the JTMP-1st column of A^T). - IF (JTMP .NE. 1) THEN - AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) - ! However, if JTMP=1, then both A^T and B must be reconstructed. - ELSE - DO J=1,D - AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) - B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 - END DO - END IF - ! Compute another simplex (try to flip again). -! CALL MAKESIMPLEX(); IF (IERR(MI) .NE. 0) CYCLE OUTER - - -!****************************************************************************** -! Due to OpenMP's handling of variable scope, the parallel implementation of -! the subroutine MAKESIMPLEX() has been in-lined here. -! -! SUBROUTINE MAKESIMPLEX() -! Given a Delaunay facet F whose containing hyperplane does not contain -! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' -! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F -! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the -! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly -! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing -! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices -! P_1, P_2, ..., P_D, P*. Then -! -! X = CENTER - P_1 -! -! is given by the solution to the nonsingular linear system -! -! A X = B where -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and -! B = [ /2, /2, ..., /2 ]^T. -! -! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the -! candidate P* that satisfies both of the following: -! -! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) -! must be on the same side of PLANE. -! -! 2) The circumball about CENTER must not contain any points in PTS in its -! interior (Delaunay property). -! -! The above are necessary and sufficient conditions for flipping the -! Delaunay simplex, given that F is indeed a Delaunay facet. -! -! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices -! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex -! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and -! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were -! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an -! extrapolation point (not a convex combination of points in PTS). - -! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed -! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. -! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal -! vector is any nonzero vector in ker A, where the matrix -! -! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. -! -! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR -! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. -! Then the last column of Q is orthogonal to the range of A^T, and in ker A. -IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. - ! Compute the QR factorization. - IPIV=0 - LQ = AT - CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 80 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! The nullspace is given by the last column of Q. - PLANE(1:D-1) = 0.0_R8 - PLANE(D) = 1.0_R8 - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & - LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 83 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Calculate the constant \alpha defining the plane. - PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) - ! Compute the sign for the side of PLANE containing Q(:,MI). - SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) - SIDE1 = SIGN(1.0_R8,SIDE1) - ! Set the RHS to P^T B. - FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) - ! Solve R^T Q^T X = P^T B for Q^T X. - CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) - ! Initialize the center, radius, simplex, and OpenMP variabls. - SIMPS(D+1,MI) = 0 - CENTER(:) = 0.0_R8 - CENTER_PRIV(:) = 0.0_R8 - MINRAD = HUGE(0.0_R8) - MINRAD_PRIV = HUGE(0.0_R8) - VERTEX_PRIV = 0 - - ! Begin Level 2 parallel loop over N points in PTS. - !$OMP PARALLEL & - ! - ! The FIRSTPRIVATE list specifies initialized variables, of which each - ! thread has a private copy. - !$OMP& FIRSTPRIVATE(CENTER_PRIV, LQ, MINRAD_PRIV, VERTEX_PRIV), & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(I, SIDE2, WORK), & - ! - ! The REDUCTION clause specifies a PRIVATE variable that will retain - ! some value (i.e., max, min, sum, etc.) upon output. - !$OMP& REDUCTION(MAX:IERR_PRIV), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& IF(PLVL2) - - ! Initialize the error flag. - IERR_PRIV = 0 - !$OMP DO SCHEDULE(STATIC) - DO I = 1, N - IF(IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. - ! Check that P* is inside the current ball. - IF (DNRM2(D, PTS(:,I) - CENTER_PRIV(:), 1) > MINRAD_PRIV) CYCLE - ! Check that P* is on the appropriate halfspace. - SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) - IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE - ! Perform a rank-1 update to the current QR factorization of A^T by - ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the - ! final column of R. - LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) - CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & - LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - IERR_PRIV = 83; CYCLE - END IF - ! Update the last element of Q^T X. - WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) - WORK(D) = LQ(D,D) / 2.0_R8 - CENTER_PRIV(1:D-1) = X(1:D-1) - CENTER_PRIV(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) - ! Get the center by applying Q to the solution. - CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER_PRIV, D, & - WORK, LWORK, IERR_PRIV) - IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. - IERR_PRIV = 83; CYCLE - END IF - ! Update the new radius, center, and simplex. - MINRAD_PRIV = DNRM2(D, CENTER_PRIV, 1) - CENTER_PRIV(:) = CENTER_PRIV(:) + PTS(:,SIMPS(1,MI)) - VERTEX_PRIV = I - END DO - !$OMP END DO - !$OMP CRITICAL(REDUC_4) - ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. - IF (VERTEX_PRIV .NE. 0) THEN - IF (DNRM2(D, PTS(:,VERTEX_PRIV) - CENTER(:), 1) < MINRAD) THEN - MINRAD = MINRAD_PRIV - CENTER(:) = CENTER_PRIV(:) - SIMPS(D+1,MI) = VERTEX_PRIV - END IF - END IF - !$OMP END CRITICAL(REDUC_4) - !$OMP END PARALLEL - ! End level 2 parallel region. - - ! Check for error flags. - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = IERR_PRIV - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - ! Check for extrapolation condition. - IF(SIMPS(D+1,MI) .NE. 0) THEN - ! Add new point to the linear system. - AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - END IF -ELSE ! Special case where D=1. - PLANE(1) = 1.0_R8 - PLANE(2) = PTS(1,SIMPS(1,MI)) - SIDE1 = SIGN(1.0_R8, PROJ(1) - PLANE(2)) - ! Initialize the radius, simplex, and OpenMP variabls. - SIMPS(2,MI) = 0 - MINRAD = HUGE(0.0_R8) - MINRAD_PRIV = HUGE(0.0_R8) - VERTEX_PRIV = 0 - ! Begin Level 2 parallel loop over N points in PTS. - !$OMP PARALLEL & - ! - ! The FIRSTPRIVATE list specifies initialized variables, of which each - ! thread has a private copy. - !$OMP& FIRSTPRIVATE(MINRAD_PRIV, VERTEX_PRIV), & - ! - ! The PRIVATE list specifies uninitialized variables, of which each - ! thread has a private copy. - !$OMP& PRIVATE(I, SIDE2), & - ! - ! Any variables not explicitly listed above receive the SHARED scope - ! by default and are visible across all threads. - !$OMP& DEFAULT(SHARED), & - ! - !$OMP& IF(PLVL2) - - !$OMP DO SCHEDULE(STATIC) - DO I = 1, N - ! Check that P* is on the appropriate halfspace. - SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 - IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE - ! Check that P* is closer than the current solution. - IF (SIDE2 > MINRAD) CYCLE - ! Update the minimum distance and save the index I. - MINRAD_PRIV = SIDE2 - VERTEX_PRIV = I - END DO - !$OMP END DO - !$OMP CRITICAL(REDUC_4) - ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. - IF (VERTEX_PRIV .NE. 0) THEN - IF (MINRAD_PRIV < MINRAD) THEN - MINRAD = MINRAD_PRIV - SIMPS(2,MI) = VERTEX_PRIV - END IF - END IF - !$OMP END CRITICAL(REDUC_4) - !$OMP END PARALLEL - ! Check for extrapolation condition. - IF(SIMPS(2,MI) .NE. 0) THEN - ! Add new point to the linear system. - AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) - B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 - END IF -END IF -! RETURN -! END SUBROUTINE MAKESIMPLEX -! End of in-lined code for MAKESIMPLEX(). -!****************************************************************************** - - - END DO - ! If the loop terminates, then a good direction was found. - ! Resume the visibility walk as normal. - CYCLE INNER - END IF - - ! Otherwise, project the extrapolation point onto the convex hull. -! CALL PROJECT(); IF (IERR_PRIV .NE. 0) CYCLE OUTER - - -!****************************************************************************** -! Due to OpenMP's handling of variable scope, the parallel (identical to serial) -! implementation of the subroutine PROJECT() has been in-lined here. -! -! SUBROUTINE PROJECT() -! Project a point outside the convex hull of the point set onto the convex hull -! by solving an inequality constrained least squares problem. The solution to -! the least squares problem gives the projection as a convex combination of the -! data points. The projection can then be computed by performing a matrix -! vector multiplication. - -! Allocate work arrays. -IF (.NOT. ALLOCATED(IWORK_DWNNLS)) THEN - ALLOCATE(IWORK_DWNNLS(D+1+N), STAT=IERR_PRIV) - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 70 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF -END IF -IF (.NOT. ALLOCATED(WORK_DWNNLS)) THEN - ALLOCATE(WORK_DWNNLS(D+1+N*5), STAT=IERR_PRIV) - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 70 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF -END IF -IF (.NOT. ALLOCATED(W_DWNNLS)) THEN - ALLOCATE(W_DWNNLS(D+1,N+1), STAT=IERR_PRIV) - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 70 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF -END IF -IF (.NOT. ALLOCATED(X_DWNNLS)) THEN - ALLOCATE(X_DWNNLS(N), STAT=IERR_PRIV) - IF(IERR_PRIV .NE. 0) THEN - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 70 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF -END IF - -! Initialize work array and settings values. -IWORK_DWNNLS(1) = D+1+5*N -IWORK_DWNNLS(2) = D+1+N -W_DWNNLS(1, :) = 1.0_R8 ! Set convexity (equality) constraint. -W_DWNNLS(2:D+1,1:N) = PTS(:,:) ! Copy data points. -W_DWNNLS(2:D+1,N+1) = PROJ(:) ! Copy extrapolation point. -! Compute the solution to the inequality constrained least squares problem to -! get the projection coefficients. -CALL DWNNLS(W_DWNNLS, D+1, 1, D, N, 0, PRGOPT_DWNNLS, X_DWNNLS, RNORML, & - IERR_PRIV, IWORK_DWNNLS, WORK_DWNNLS) -IF (IERR_PRIV .EQ. 1) THEN ! Failure to converge. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 71 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER -ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. - ! Store the error code. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 72 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER -END IF -! Compute the actual projection via matrix vector multiplication. -CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) -! Zero all weights that are approximately zero and renormalize the sum. -WHERE (X_DWNNLS < EPSL) X_DWNNLS = 0.0_R8 -X_DWNNLS(:) = X_DWNNLS(:) / SUM(X_DWNNLS) -! Compute the actual projection via matrix vector multiplication. -CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) -RNORML = DNRM2(D, PROJ(:) - Q(:,MI), 1) -! RETURN -! END SUBROUTINE PROJECT -! End of in-lined code for PROJECT(). -!****************************************************************************** - - - ! Check the value of RNORML for over-extrapolation. - IF (RNORML > EXTRAPL * PTS_DIAM) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! If present, record the unscaled RNORM output. - IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE - ! Set the error flag and skip this point. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 2 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - - ! Otherwise, restore the previous simplex and continue with the - ! projected value. - SIMPS(D+1,MI) = ITMP - AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) - B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 - IEXTRAPS = IEXTRAPS - 1 ! Decrement the budget. - END IF - - ! End of inner loop for finding each interpolation point. - END DO INNER - - ! Check for budget violation conditions. - IF (K > IBUDGETL) THEN - SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. - ! Set the error flag and skip this point. - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 60 - !$OMP END CRITICAL(CHECK_IERR) - CYCLE OUTER - END IF - - ! If the residual is nonzero, set the extrapolation flag. - IF (RNORML > EPSL) THEN - !$OMP CRITICAL(CHECK_IERR) - IERR(MI) = 1 - !$OMP END CRITICAL(CHECK_IERR) - END IF - - ! If present, record the RNORM output. - IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE - -END DO OUTER ! End of outer loop over all interpolation points. -!$OMP END DO - -! If INTERP_IN and INTERP_OUT are present, compute all values f(q). -IF (PRESENT(INTERP_IN)) THEN - ! Level 1 parallel loop over all interpolation points. - !$OMP DO SCHEDULE(STATIC) - DO MI = 1, M - ! Check for errors. - IF (IERR(MI) .LE. 1) THEN - ! Compute the weighted sum of vertex response values. - DO K = 1, D+1 - INTERP_OUT(:,MI) = INTERP_OUT(:,MI) & - + INTERP_IN(:,SIMPS(K,MI)) * WEIGHTS(K,MI) - END DO - END IF - END DO - !$OMP END DO -END IF - -! Free optional work arrays. -IF (ALLOCATED(IWORK_DWNNLS)) DEALLOCATE(IWORK_DWNNLS) -IF (ALLOCATED(WORK_DWNNLS)) DEALLOCATE(WORK_DWNNLS) -IF (ALLOCATED(W_DWNNLS)) DEALLOCATE(W_DWNNLS) -IF (ALLOCATED(X_DWNNLS)) DEALLOCATE(X_DWNNLS) -!$OMP END PARALLEL -! End of Level 1 parallel region. - -! Free dynamic work arrays. -DEALLOCATE(WORK) - -RETURN - -CONTAINS ! Internal subroutines and functions. - -SUBROUTINE RESCALE(MINDIST, DIAMETER, SCALE) -! Rescale and transform data to be centered at the origin with unit -! radius. -! -! The parallel implementation of this subroutine exploits parallelism -! over loops of length N. For nested loops, this subroutine follows -! the OpenMP recommendation of a static schedule with a fixed chunk -! size (of 100). -! -! On output, PTS and Q have been rescaled and shifted. All the data -! points in PTS are centered with unit radius, and the points in Q -! have been shifted and scaled in relation to PTS. -! -! MINDIST is a real number containing the (scaled) minimum distance -! between any two data points in PTS. -! -! DIAMETER is a real number containing the (scaled) diameter of the -! data set PTS. -! -! SCALE contains the real factor used to transform the data and -! interpolation points: scaled value = (original value - -! barycenter of data points)/SCALE. - -! Output arguments. -REAL(KIND=R8), INTENT(OUT) :: MINDIST, DIAMETER, SCALE - -! Local variables. -REAL(KIND=R8) :: PTS_CENTER(D) ! The center of the data points PTS. -REAL(KIND=R8) :: DISTANCE ! The current distance. - -! Initialize local values. -MINDIST = HUGE(0.0_R8) -DIAMETER = 0.0_R8 -SCALE = 0.0_R8 - -! Compute barycenter of all data points. -PTS_CENTER(:) = SUM(PTS(:,:), DIM=2)/REAL(N, KIND=R8) -! Center the points. -FORALL (I = 1:N) PTS(:,I) = PTS(:,I) - PTS_CENTER(:) -! Compute the scale factor (for unit radius). -!$OMP PARALLEL DO & -!$OMP& PRIVATE(I, DISTANCE), & -!$OMP& REDUCTION(MAX:SCALE), & -!$OMP& SCHEDULE(STATIC), & -!$OMP& DEFAULT(SHARED) -DO I = 1, N ! Cycle through all points again. - DISTANCE = DNRM2(D, PTS(:,I), 1) ! Compute the distance from the center. - IF (DISTANCE > SCALE) THEN ! Compare to the current radius. - SCALE = DISTANCE - END IF -END DO -!$OMP END PARALLEL DO -! Scale the points to unit radius. -PTS = PTS / SCALE -! Also transform Q similarly. -FORALL (I = 1:M) Q(:,I) = (Q(:,I) - PTS_CENTER(:)) / SCALE -! Compute the minimum and maximum distances. -IF (EXACTL) THEN - ! If exact error error checking is turned on, then compute the DIAMETER - ! and MINDIST values. - !$OMP PARALLEL DO & - !$OMP& PRIVATE(I, DISTANCE), & - !$OMP& REDUCTION(MAX:DIAMETER), & - !$OMP& REDUCTION(MIN:MINDIST), & - !$OMP& SCHEDULE(STATIC, 100), & - !$OMP& DEFAULT(SHARED) - DO I = 1, N ! Cycle through all pairs of points. - DO J = I + 1, N - DISTANCE = DNRM2(D, PTS(:,I) - PTS(:,J), 1) ! Compute the distance. - IF (DISTANCE > DIAMETER) THEN ! Compare to the current diameter. - DIAMETER = DISTANCE - END IF - IF (DISTANCE < MINDIST) THEN ! Compare to the current minimum distance. - MINDIST = DISTANCE - END IF - END DO - END DO - !$OMP END PARALLEL DO -ELSE - ! If exact error checking is turned off, then the diameter is approximately - ! 2.0 after rescaling and centering the points. The MINDIST is not computed. - DIAMETER = 2.0_R8 - MINDIST = 1.0_R8 -END IF -RETURN -END SUBROUTINE RESCALE - -END SUBROUTINE DELAUNAYSPARSEP diff --git a/toms1012/lapack.f b/toms1012/lapack.f deleted file mode 100644 index 3dff8b8..0000000 --- a/toms1012/lapack.f +++ /dev/null @@ -1,4369 +0,0 @@ - SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine (version 3.7.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -* -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER INB, INBMIN, IXOVER - PARAMETER( INB = 1, INBMIN = 2, IXOVER = 3 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, - $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN -* .. -* .. External Subroutines .. - EXTERNAL DGEQRF, DLAQP2, DLAQPS, DORMQR, DSWAP, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - DOUBLE PRECISION DNRM2 - EXTERNAL ILAENV, DNRM2 -* .. -* .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test input arguments -* ==================== -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF -* - IF( INFO.EQ.0 ) THEN - MINMN = MIN( M, N ) - IF( MINMN.EQ.0 ) THEN - IWS = 1 - LWKOPT = 1 - ELSE - IWS = 3*N + 1 - NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) - LWKOPT = 2*N + ( N + 1 )*NB - END IF - WORK( 1 ) = LWKOPT -* - IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQP3', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Move initial columns up front. -* - NFXD = 1 - DO 10 J = 1, N - IF( JPVT( J ).NE.0 ) THEN - IF( J.NE.NFXD ) THEN - CALL DSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 ) - JPVT( J ) = JPVT( NFXD ) - JPVT( NFXD ) = J - ELSE - JPVT( J ) = J - END IF - NFXD = NFXD + 1 - ELSE - JPVT( J ) = J - END IF - 10 CONTINUE - NFXD = NFXD - 1 -* -* Factorize fixed columns -* ======================= -* -* Compute the QR factorization of fixed columns and update -* remaining columns. -* - IF( NFXD.GT.0 ) THEN - NA = MIN( M, NFXD ) -*CC CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) - CALL DGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO ) - IWS = MAX( IWS, INT( WORK( 1 ) ) ) - IF( NA.LT.N ) THEN -*CC CALL DORM2R( 'LEFT', 'TRANSPOSE', M, N-NA, NA, A, LDA, -*CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) - CALL DORMQR( 'LEFT', 'TRANSPOSE', M, N-NA, NA, A, LDA, TAU, - $ A( 1, NA+1 ), LDA, WORK, LWORK, INFO ) - IWS = MAX( IWS, INT( WORK( 1 ) ) ) - END IF - END IF -* -* Factorize free columns -* ====================== -* - IF( NFXD.LT.MINMN ) THEN -* - SM = M - NFXD - SN = N - NFXD - SMINMN = MINMN - NFXD -* -* Determine the block size. -* - NB = ILAENV( INB, 'DGEQRF', ' ', SM, SN, -1, -1 ) - NBMIN = 2 - NX = 0 -* - IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN -* -* Determine when to cross over from blocked to unblocked -* code. -* - NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', SM, SN, -1, - $ -1 ) ) -* -* - IF( NX.LT.SMINMN ) THEN -* -* Determine if workspace is large enough for blocked code. -* - MINWS = 2*SN + ( SN+1 )*NB - IWS = MAX( IWS, MINWS ) - IF( LWORK.LT.MINWS ) THEN -* -* Not enough workspace to use optimal NB: Reduce NB and -* determine the minimum value of NB. -* - NB = ( LWORK-2*SN ) / ( SN+1 ) - NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', SM, N, - $ -1, -1 ) ) -* -* - END IF - END IF - END IF -* -* Initialize partial column norms. The first N elements of work -* store the exact column norms. -* - DO 20 J = NFXD + 1, N - WORK( J ) = DNRM2( SM, A( NFXD+1, J ), 1 ) - WORK( N+J ) = WORK( J ) - 20 CONTINUE -* - IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. - $ ( NX.LT.SMINMN ) ) THEN -* -* Use blocked code initially. -* - J = NFXD + 1 -* -* Compute factorization: while loop. -* -* - TOPBMN = MINMN - NX - 30 CONTINUE - IF( J.LE.TOPBMN ) THEN - JB = MIN( NB, TOPBMN-J+1 ) -* -* Factorize JB columns among columns J:N. -* - CALL DLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, - $ JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ), - $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 ) -* - J = J + FJB - GO TO 30 - END IF - ELSE - J = NFXD + 1 - END IF -* -* Use unblocked code to factor the last or only block. -* -* - IF( J.LE.MINMN ) - $ CALL DLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), - $ TAU( J ), WORK( J ), WORK( N+J ), - $ WORK( 2*N+1 ) ) -* - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DGEQP3 -* - END - SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGEQR2 computes a QR factorization of a real m by n matrix A: -* A = Q * R. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix A. -* On exit, the elements on and above the diagonal of the array -* contain the min(m,n) by n upper trapezoidal matrix R (R is -* upper triangular if m >= n); the elements below the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of elementary reflectors (see Further Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(1) H(2) . . . H(k), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v**T -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, K - DOUBLE PRECISION AII -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQR2', -INFO ) - RETURN - END IF -* - K = MIN( M, N ) -* - DO 10 I = 1, K -* -* Generate elementary reflector H(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAU( I ) ) - IF( I.LT.N ) THEN -* -* Apply H(i) to A(i:m,i+1:n) from the left -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = AII - END IF - 10 CONTINUE - RETURN -* -* End of DGEQR2 -* - END - SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGEQRF computes a QR factorization of a real M-by-N matrix A: -* A = Q * R. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix A. -* On exit, the elements on and above the diagonal of the array -* contain the min(M,N)-by-N upper trapezoidal matrix R (R is -* upper triangular if m >= n); the elements below the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of min(m,n) elementary reflectors (see Further -* Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension -* (MAX(1,LWORK)) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is -* the optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(1) H(2) . . . H(k), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v**T -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQRF', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, - $ -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code initially -* - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -* -* Compute the QR factorization of the current block -* A(i:m,i:i+ib-1) -* - CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H**T to A(i:m,i+ib:n) from the left -* - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF - 10 CONTINUE - ELSE - I = 1 - END IF -* -* Use unblocked code to factor the last or only block. -* - IF( I.LE.K ) - $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* - WORK( 1 ) = IWS - RETURN -* -* End of DGEQRF -* - END - SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETF2 computes an LU factorization of a general m-by-n matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, U(k,k) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION SFMIN - INTEGER I, J, JP -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - INTEGER IDAMAX - EXTERNAL DLAMCH, IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DGER, DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Compute machine safe minimum -* - SFMIN = DLAMCH('S') -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP - IF( A( JP, J ).NE.ZERO ) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* Compute elements J+1:M of J-th column. -* - IF( J.LT.M ) THEN - IF( ABS(A( J, J )) .GE. SFMIN ) THEN - CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) - ELSE - DO 20 I = 1, M-J - A( J+I, J ) = A( J+I, J ) / A( J, J ) - 20 CONTINUE - END IF - END IF -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, - $ A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of DGETF2 -* - END - SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETRF computes an LU factorization of a general M-by-N matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL DGETF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGETRF -* - END - SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGETRS solves a system of linear equations -* A * X = B or A**T * X = B -* with a general N-by-N matrix A using the LU factorization computed -* by DGETRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A**T* X = B (Transpose) -* = 'C': A**T* X = B (Conjugate transpose = Transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The factors L and U from the factorization A = P*L*U -* as computed by DGETRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from DGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLASWP, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( NOTRAN ) THEN -* -* Solve A * X = B. -* -* Apply row interchanges to the right hand sides. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A**T * X = B. -* -* Solve U**T *X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve L**T *X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of DGETRS -* - END - DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. -* -* Purpose -* ======= -* -* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary -* overflow. -* -* Arguments -* ========= -* -* X (input) DOUBLE PRECISION -* Y (input) DOUBLE PRECISION -* X and Y specify the values x and y. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION W, XABS, YABS, Z -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - XABS = ABS( X ) - YABS = ABS( Y ) - W = MAX( XABS, YABS ) - Z = MIN( XABS, YABS ) - IF( Z.EQ.ZERO ) THEN - DLAPY2 = W - ELSE - DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) - END IF - RETURN -* -* End of DLAPY2 -* - END - SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, - $ WORK ) -* -* -- LAPACK auxiliary routine (version 3.7.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -* -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER LDA, M, N, OFFSET -* .. -* .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), - $ WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, ITEMP, J, MN, OFFPI, PVT - DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, DSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DNRM2 - EXTERNAL IDAMAX, DLAMCH, DNRM2 -* .. -* .. Executable Statements .. -* - MN = MIN( M-OFFSET, N ) - TOL3Z = SQRT(DLAMCH('EPSILON')) -* -* Compute factorization. -* - DO 20 I = 1, MN -* - OFFPI = OFFSET + I -* -* Determine ith pivot column and swap if necessary. -* - PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 ) -* - IF( PVT.NE.I ) THEN - CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) - ITEMP = JPVT( PVT ) - JPVT( PVT ) = JPVT( I ) - JPVT( I ) = ITEMP - VN1( PVT ) = VN1( I ) - VN2( PVT ) = VN2( I ) - END IF -* -* Generate elementary reflector H(i). -* - IF( OFFPI.LT.M ) THEN - CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, - $ TAU( I ) ) - ELSE - CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) - END IF -* - IF( I.LT.N ) THEN -* -* Apply H(i)**T to A(offset+i:m,i+1:n) from the left. -* - AII = A( OFFPI, I ) - A( OFFPI, I ) = ONE - CALL DLARF( 'LEFT', M-OFFPI+1, N-I, A( OFFPI, I ), 1, - $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) - A( OFFPI, I ) = AII - END IF -* -* Update partial column norms. -* - DO 10 J = I + 1, N - IF( VN1( J ).NE.ZERO ) THEN -* -* NOTE: The following 4 lines follow from the analysis in -* Lapack Working Note 176. -* - TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 - IF( TEMP2 .LE. TOL3Z ) THEN - IF( OFFPI.LT.M ) THEN - VN1( J ) = DNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) - VN2( J ) = VN1( J ) - ELSE - VN1( J ) = ZERO - VN2( J ) = ZERO - END IF - ELSE - VN1( J ) = VN1( J )*SQRT( TEMP ) - END IF - END IF - 10 CONTINUE -* - 20 CONTINUE -* - RETURN -* -* End of DLAQP2 -* - END - SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, - $ VN2, AUXV, F, LDF ) -* -* -- LAPACK auxiliary routine (version 3.7.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -* -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER KB, LDA, LDF, M, N, NB, OFFSET -* .. -* .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), - $ VN1( * ), VN2( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK - DOUBLE PRECISION AKK, TEMP, TEMP2, TOL3Z -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, NINT, SQRT -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DNRM2 - EXTERNAL IDAMAX, DLAMCH, DNRM2 -* .. -* .. Executable Statements .. -* - LASTRK = MIN( M, N+OFFSET ) - LSTICC = 0 - K = 0 - TOL3Z = SQRT(DLAMCH('EPSILON')) -* -* Beginning of while loop. -* - 10 CONTINUE - IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN - K = K + 1 - RK = OFFSET + K -* -* Determine ith pivot column and swap if necessary -* - PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) - IF( PVT.NE.K ) THEN - CALL DSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 ) - CALL DSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF ) - ITEMP = JPVT( PVT ) - JPVT( PVT ) = JPVT( K ) - JPVT( K ) = ITEMP - VN1( PVT ) = VN1( K ) - VN2( PVT ) = VN2( K ) - END IF -* -* Apply previous Householder reflectors to column K: -* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**T. -* - IF( K.GT.1 ) THEN - CALL DGEMV( 'NO TRANSPOSE', M-RK+1, K-1, -ONE, A( RK, 1 ), - $ LDA, F( K, 1 ), LDF, ONE, A( RK, K ), 1 ) - END IF -* -* Generate elementary reflector H(k). -* - IF( RK.LT.M ) THEN - CALL DLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) - ELSE - CALL DLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) - END IF -* - AKK = A( RK, K ) - A( RK, K ) = ONE -* -* Compute Kth column of F: -* -* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**T*A(RK:M,K). -* - IF( K.LT.N ) THEN - CALL DGEMV( 'TRANSPOSE', M-RK+1, N-K, TAU( K ), - $ A( RK, K+1 ), LDA, A( RK, K ), 1, ZERO, - $ F( K+1, K ), 1 ) - END IF -* -* Padding F(1:K,K) with zeros. -* - DO 20 J = 1, K - F( J, K ) = ZERO - 20 CONTINUE -* -* Incremental updating of F: -* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**T -* *A(RK:M,K). -* - IF( K.GT.1 ) THEN - CALL DGEMV( 'TRANSPOSE', M-RK+1, K-1, -TAU( K ), A( RK, 1 ), - $ LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 ) -* - CALL DGEMV( 'NO TRANSPOSE', N, K-1, ONE, F( 1, 1 ), LDF, - $ AUXV( 1 ), 1, ONE, F( 1, K ), 1 ) - END IF -* -* Update the current row of A: -* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**T. -* - IF( K.LT.N ) THEN - CALL DGEMV( 'NO TRANSPOSE', N-K, K, -ONE, F( K+1, 1 ), LDF, - $ A( RK, 1 ), LDA, ONE, A( RK, K+1 ), LDA ) - END IF -* -* Update partial column norms. -* - IF( RK.LT.LASTRK ) THEN - DO 30 J = K + 1, N - IF( VN1( J ).NE.ZERO ) THEN -* -* NOTE: The following 4 lines follow from the analysis -* in -* Lapack Working Note 176. -* - TEMP = ABS( A( RK, J ) ) / VN1( J ) - TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) - TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 - IF( TEMP2 .LE. TOL3Z ) THEN - VN2( J ) = DBLE( LSTICC ) - LSTICC = J - ELSE - VN1( J ) = VN1( J )*SQRT( TEMP ) - END IF - END IF - 30 CONTINUE - END IF -* - A( RK, K ) = AKK -* -* End of while loop. -* - GO TO 10 - END IF - KB = K - RK = OFFSET + KB -* -* Apply the block reflector to the rest of the matrix: -* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - -* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**T. -* - IF( KB.LT.MIN( N, M-OFFSET ) ) THEN - CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M-RK, N-KB, KB, -ONE, - $ A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, - $ A( RK+1, KB+1 ), LDA ) - END IF -* -* Recomputation of difficult columns. -* - 40 CONTINUE - IF( LSTICC.GT.0 ) THEN - ITEMP = NINT( VN2( LSTICC ) ) - VN1( LSTICC ) = DNRM2( M-RK, A( RK+1, LSTICC ), 1 ) -* -* NOTE: The computation of VN1( LSTICC ) relies on the fact that -* SNRM2 does not fail on vectors with norm below the value of -* SQRT(DLAMCH('S')) -* - VN2( LSTICC ) = VN1( LSTICC ) - LSTICC = ITEMP - GO TO 40 - END IF -* - RETURN -* -* End of DLAQPS -* - END - SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER SIDE - INTEGER INCV, LDC, M, N - DOUBLE PRECISION TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLARF applies a real elementary reflector H to a real m by n matrix -* C, from either the left or the right. H is represented in the form -* -* H = I - tau * v * v**T -* -* where tau is a real scalar and v is a real vector. -* -* If tau = 0, then H is taken to be the unit matrix. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': form H * C -* = 'R': form C * H -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* V (input) DOUBLE PRECISION array, dimension -* (1 + (M-1)*abs(INCV)) if SIDE = 'L' -* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' -* The vector v in the representation of H. V is not used if -* TAU = 0. -* -* INCV (input) INTEGER -* The increment between elements of v. INCV <> 0. -* -* TAU (input) DOUBLE PRECISION -* The value tau in the representation of H. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by the matrix H * C if SIDE = 'L', -* or C * H if SIDE = 'R'. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* (N) if SIDE = 'L' -* or (M) if SIDE = 'R' -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL APPLYLEFT - INTEGER I, LASTV, LASTC -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DGER -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILADLR, ILADLC - EXTERNAL LSAME, ILADLR, ILADLC -* .. -* .. Executable Statements .. -* - APPLYLEFT = LSAME( SIDE, 'L' ) - LASTV = 0 - LASTC = 0 - IF( TAU.NE.ZERO ) THEN -! Set up variables for scanning V. LASTV begins pointing to the end -! of V. - IF( APPLYLEFT ) THEN - LASTV = M - ELSE - LASTV = N - END IF - IF( INCV.GT.0 ) THEN - I = 1 + (LASTV-1) * INCV - ELSE - I = 1 - END IF -! Look for the last non-zero row in V. - DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) - LASTV = LASTV - 1 - I = I - INCV - END DO - IF( APPLYLEFT ) THEN -! Scan for the last non-zero column in C(1:lastv,:). - LASTC = ILADLC(LASTV, N, C, LDC) - ELSE -! Scan for the last non-zero row in C(:,1:lastv). - LASTC = ILADLR(M, LASTV, C, LDC) - END IF - END IF -! Note that lastc.eq.0 renders the BLAS operations null; no special -! case is needed at this level. - IF( APPLYLEFT ) THEN -* -* Form H * C -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) -* - CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, - $ ZERO, WORK, 1 ) -* -* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * -* w(1:lastc,1)**T -* - CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) - END IF - ELSE -* -* Form C * H -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) -* - CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, - $ V, INCV, ZERO, WORK, 1 ) -* -* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * -* v(1:lastv,1)**T -* - CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) - END IF - END IF - RETURN -* -* End of DLARF -* - END - SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, - $ T, LDT, C, LDC, WORK, LDWORK ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, SIDE, STOREV, TRANS - INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), - $ WORK( LDWORK, * ) -* .. -* -* Purpose -* ======= -* -* DLARFB applies a real block reflector H or its transpose H**T to a -* real m by n matrix C, from either the left or the right. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply H or H**T from the Left -* = 'R': apply H or H**T from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply H (No transpose) -* = 'T': apply H**T (Transpose) -* -* DIRECT (input) CHARACTER*1 -* Indicates how H is formed from a product of elementary -* reflectors -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Indicates how the vectors which define the elementary -* reflectors are stored: -* = 'C': Columnwise -* = 'R': Rowwise -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* K (input) INTEGER -* The order of the matrix T (= the number of elementary -* reflectors whose product defines the block reflector). -* -* V (input) DOUBLE PRECISION array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,M) if STOREV = 'R' and SIDE = 'L' -* (LDV,N) if STOREV = 'R' and SIDE = 'R' -* The matrix V. See Further Details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); -* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); -* if STOREV = 'R', LDV >= K. -* -* T (input) DOUBLE PRECISION array, dimension (LDT,K) -* The triangular k by k matrix T in the representation of the -* block reflector. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) -* -* LDWORK (input) INTEGER -* The leading dimension of the array WORK. -* If SIDE = 'L', LDWORK >= max(1,N); -* if SIDE = 'R', LDWORK >= max(1,M). -* -* Further Details -* =============== -* -* The shape of the matrix V and the storage of the vectors which define -* the H(i) is best illustrated by the following example with n = 5 and -* k = 3. The elements equal to 1 are not stored; the corresponding -* array elements are modified but restored on exit. The rest of the -* array is not used. -* -* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -* -* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -* ( v1 1 ) ( 1 v2 v2 v2 ) -* ( v1 v2 1 ) ( 1 v3 v3 ) -* ( v1 v2 v3 ) -* ( v1 v2 v3 ) -* -* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -* -* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -* ( v1 v2 v3 ) ( v2 v2 v2 1 ) -* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -* ( 1 v3 ) -* ( 1 ) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - CHARACTER TRANST - INTEGER I, J, LASTV, LASTC -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILADLR, ILADLC - EXTERNAL LSAME, ILADLR, ILADLC -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DTRMM -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( LSAME( TRANS, 'N' ) ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* - IF( LSAME( STOREV, 'C' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 ) (first K rows) -* ( V2 ) -* where V1 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in -* WORK) -* -* W := C1**T -* - DO 10 J = 1, K - CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 10 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2**T *V2 -* - CALL DGEMM( 'Transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**T -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - V2 * W**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**T -* - DO 30 J = 1, K - DO 20 I = 1, LASTC - C( J, I ) = C( J, I ) - WORK( I, J ) - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C1 -* - DO 40 J = 1, K - CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) - 40 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2 * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**T -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - W * V2**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 60 J = 1, K - DO 50 I = 1, LASTC - C( I, J ) = C( I, J ) - WORK( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - ELSE -* -* Let V = ( V1 ) -* ( V2 ) (last K rows) -* where V2 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in -* WORK) -* -* W := C2**T -* - DO 70 J = 1, K - CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - 70 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1**T*V1 -* - CALL DGEMM( 'Transpose', 'No transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**T -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - V1 * W**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) - END IF -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) -* -* C2 := C2 - W**T -* - DO 90 J = 1, K - DO 80 I = 1, LASTC - C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C2 -* - DO 100 J = 1, K - CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 100 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1 * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**T -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - W * V1**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) - END IF -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, - $ WORK, LDWORK ) -* -* C2 := C2 - W -* - DO 120 J = 1, K - DO 110 I = 1, LASTC - C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) - 110 CONTINUE - 120 CONTINUE - END IF - END IF -* - ELSE IF( LSAME( STOREV, 'R' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 V2 ) (V1: first K columns) -* where V1 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) -* (stored in WORK) -* -* W := C1**T -* - DO 130 J = 1, K - CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 130 CONTINUE -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2**T*V2**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**T * W**T -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - V2**T * W**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, - $ ONE, C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**T -* - DO 150 J = 1, K - DO 140 I = 1, LASTC - C( J, I ) = C( J, I ) - WORK( I, J ) - 140 CONTINUE - 150 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) -* -* W := C1 -* - DO 160 J = 1, K - CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) - 160 CONTINUE -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C2 * V2**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( LASTV.GT.K ) THEN -* -* C2 := C2 - W * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 180 J = 1, K - DO 170 I = 1, LASTC - C( I, J ) = C( I, J ) - WORK( I, J ) - 170 CONTINUE - 180 CONTINUE -* - END IF -* - ELSE -* -* Let V = ( V1 V2 ) (V2: last K columns) -* where V2 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* - LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) -* -* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) -* (stored in WORK) -* -* W := C2**T -* - DO 190 J = 1, K - CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - 190 CONTINUE -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1**T * V1**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**T * W**T -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - V1**T * W**T -* - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) -* -* C2 := C2 - W**T -* - DO 210 J = 1, K - DO 200 I = 1, LASTC - C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) - 200 CONTINUE - 210 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) -* -* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) -* -* W := C2 -* - DO 220 J = 1, K - CALL DCOPY( LASTC, C( 1, LASTV-K+J ), 1, - $ WORK( 1, J ), 1 ) - 220 CONTINUE -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) - IF( LASTV.GT.K ) THEN -* -* W := W + C1 * V1**T -* - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( LASTV.GT.K ) THEN -* -* C1 := C1 - W * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, - $ WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 240 J = 1, K - DO 230 I = 1, LASTC - C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) - 230 CONTINUE - 240 CONTINUE -* - END IF -* - END IF - END IF -* - RETURN -* -* End of DLARFB -* - END - SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION ALPHA, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* Purpose -* ======= -* -* DLARFG generates a real elementary reflector H of order n, such -* that -* -* H * ( alpha ) = ( beta ), H**T * H = I. -* ( x ) ( 0 ) -* -* where alpha and beta are scalars, and x is an (n-1)-element real -* vector. H is represented in the form -* -* H = I - tau * ( 1 ) * ( 1 v**T ) , -* ( v ) -* -* where tau is a real scalar and v is a real (n-1)-element -* vector. -* -* If the elements of x are all zero, then tau = 0 and H is taken to be -* the unit matrix. -* -* Otherwise 1 <= tau <= 2. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the elementary reflector. -* -* ALPHA (input/output) DOUBLE PRECISION -* On entry, the value alpha. -* On exit, it is overwritten with the value beta. -* -* X (input/output) DOUBLE PRECISION array, dimension -* (1+(N-2)*abs(INCX)) -* On entry, the vector x. -* On exit, it is overwritten with the vector v. -* -* INCX (input) INTEGER -* The increment between elements of X. INCX > 0. -* -* TAU (output) DOUBLE PRECISION -* The value tau. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, KNT - DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 - EXTERNAL DLAMCH, DLAPY2, DNRM2 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN -* .. -* .. External Subroutines .. - EXTERNAL DSCAL -* .. -* .. Executable Statements .. -* - IF( N.LE.1 ) THEN - TAU = ZERO - RETURN - END IF -* - XNORM = DNRM2( N-1, X, INCX ) -* - IF( XNORM.EQ.ZERO ) THEN -* -* H = I -* - TAU = ZERO - ELSE -* -* general case -* - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) - KNT = 0 - IF( ABS( BETA ).LT.SAFMIN ) THEN -* -* XNORM, BETA may be inaccurate; scale X and recompute them -* - RSAFMN = ONE / SAFMIN - 10 CONTINUE - KNT = KNT + 1 - CALL DSCAL( N-1, RSAFMN, X, INCX ) - BETA = BETA*RSAFMN - ALPHA = ALPHA*RSAFMN - IF( ABS( BETA ).LT.SAFMIN ) - $ GO TO 10 -* -* New BETA is at most 1, at least SAFMIN -* - XNORM = DNRM2( N-1, X, INCX ) - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - END IF - TAU = ( BETA-ALPHA ) / BETA - CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) -* -* If ALPHA is subnormal, it may lose relative accuracy -* - DO 20 J = 1, KNT - BETA = BETA*SAFMIN - 20 CONTINUE - ALPHA = BETA - END IF -* - RETURN -* -* End of DLARFG -* - END - SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* Purpose -* ======= -* -* DLARFT forms the triangular factor T of a real block reflector H -* of order n, which is defined as a product of k elementary reflectors. -* -* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; -* -* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. -* -* If STOREV = 'C', the vector which defines the elementary reflector -* H(i) is stored in the i-th column of the array V, and -* -* H = I - V * T * V**T -* -* If STOREV = 'R', the vector which defines the elementary reflector -* H(i) is stored in the i-th row of the array V, and -* -* H = I - V**T * T * V -* -* Arguments -* ========= -* -* DIRECT (input) CHARACTER*1 -* Specifies the order in which the elementary reflectors are -* multiplied to form the block reflector: -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Specifies how the vectors which define the elementary -* reflectors are stored (see also Further Details): -* = 'C': columnwise -* = 'R': rowwise -* -* N (input) INTEGER -* The order of the block reflector H. N >= 0. -* -* K (input) INTEGER -* The order of the triangular factor T (= the number of -* elementary reflectors). K >= 1. -* -* V (input/output) DOUBLE PRECISION array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,N) if STOREV = 'R' -* The matrix V. See further details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i). -* -* T (output) DOUBLE PRECISION array, dimension (LDT,K) -* The k by k triangular factor T of the block reflector. -* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is -* lower triangular. The rest of the array is not used. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* Further Details -* =============== -* -* The shape of the matrix V and the storage of the vectors which define -* the H(i) is best illustrated by the following example with n = 5 and -* k = 3. The elements equal to 1 are not stored; the corresponding -* array elements are modified but restored on exit. The rest of the -* array is not used. -* -* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -* -* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -* ( v1 1 ) ( 1 v2 v2 v2 ) -* ( v1 v2 1 ) ( 1 v3 v3 ) -* ( v1 v2 v3 ) -* ( v1 v2 v3 ) -* -* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -* -* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -* ( v1 v2 v3 ) ( v2 v2 v2 1 ) -* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -* ( 1 v3 ) -* ( 1 ) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, PREVLASTV, LASTV - DOUBLE PRECISION VII -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DTRMV -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - PREVLASTV = N - DO 20 I = 1, K - PREVLASTV = MAX( I, PREVLASTV ) - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 10 J = 1, I - T( J, I ) = ZERO - 10 CONTINUE - ELSE -* -* general case -* - VII = V( I, I ) - V( I, I ) = ONE - IF( LSAME( STOREV, 'C' ) ) THEN -! Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) -* - CALL DGEMV( 'Transpose', J-I+1, I-1, -TAU( I ), - $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, - $ T( 1, I ), 1 ) - ELSE -! Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T -* - CALL DGEMV( 'No transpose', I-1, J-I+1, -TAU( I ), - $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, - $ T( 1, I ), 1 ) - END IF - V( I, I ) = VII -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MAX( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - 20 CONTINUE - ELSE - PREVLASTV = 1 - DO 40 I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 30 J = I, K - T( J, I ) = ZERO - 30 CONTINUE - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN - VII = V( N-K+I, I ) - V( N-K+I, I ) = ONE -! Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) := -* - tau(i) * V(j:n-k+i,i+1:k)**T * -* V(j:n-k+i,i) -* - CALL DGEMV( 'Transpose', N-K+I-J+1, K-I, -TAU( I ), - $ V( J, I+1 ), LDV, V( J, I ), 1, ZERO, - $ T( I+1, I ), 1 ) - V( N-K+I, I ) = VII - ELSE - VII = V( I, N-K+I ) - V( I, N-K+I ) = ONE -! Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) := -* - tau(i) * V(i+1:k,j:n-k+i) * -* V(i,j:n-k+i)**T -* - CALL DGEMV( 'No transpose', K-I, N-K+I-J+1, - $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, - $ ZERO, T( I+1, I ), 1 ) - V( I, N-K+I ) = VII - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - T( I, I ) = TAU( I ) - END IF - 40 CONTINUE - END IF - RETURN -* -* End of DLARFT -* - END - SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASWP performs a series of row interchanges on the matrix A. -* One row interchange is initiated for each of rows K1 through K2 of A. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the matrix of column dimension N to which the row -* interchanges will be applied. -* On exit, the permuted matrix. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* -* K1 (input) INTEGER -* The first element of IPIV for which a row interchange will -* be done. -* -* K2 (input) INTEGER -* The last element of IPIV for which a row interchange will -* be done. -* -* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) -* The vector of pivot indices. Only the elements in positions -* K1 through K2 of IPIV are accessed. -* IPIV(K) = L implies rows K and L are to be interchanged. -* -* INCX (input) INTEGER -* The increment between successive values of IPIV. If IPIV -* is negative, the pivots are applied in reverse order. -* -* Further Details -* =============== -* -* Modified by -* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - DOUBLE PRECISION TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) for each of rows K1 through K2. -* - IF( INCX.GT.0 ) THEN - IX0 = K1 - I1 = K1 - I2 = K2 - INC = 1 - ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX - I1 = K2 - I2 = K1 - INC = -1 - ELSE - RETURN - END IF -* - N32 = ( N / 32 )*32 - IF( N32.NE.0 ) THEN - DO 30 J = 1, N32, 32 - IX = IX0 - DO 20 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 10 K = J, J + 31 - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 10 CONTINUE - END IF - IX = IX + INCX - 20 CONTINUE - 30 CONTINUE - END IF - IF( N32.NE.N ) THEN - N32 = N32 + 1 - IX = IX0 - DO 50 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 40 K = N32, N - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 40 CONTINUE - END IF - IX = IX + INCX - 50 CONTINUE - END IF -* - RETURN -* -* End of DLASWP -* - END - SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORM2R overwrites the general real m by n matrix C with -* -* Q * C if SIDE = 'L' and TRANS = 'N', or -* -* Q**T* C if SIDE = 'L' and TRANS = 'T', or -* -* C * Q if SIDE = 'R' and TRANS = 'N', or -* -* C * Q**T if SIDE = 'R' and TRANS = 'T', -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**T from the Left -* = 'R': apply Q or Q**T from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply Q (No transpose) -* = 'T': apply Q**T (Transpose) -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGEQRF in the first k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* (N) if SIDE = 'L', -* (M) if SIDE = 'R' -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORM2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) - $ THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), - $ LDC, WORK ) - A( I, I ) = AII - 10 CONTINUE - RETURN -* -* End of DORM2R -* - END - SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORMQR overwrites the general real M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'T': Q**T * C C * Q**T -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**T from the Left; -* = 'R': apply Q or Q**T from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'T': Transpose, apply Q**T. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGEQRF in the first k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension -* (MAX(1,LWORK)) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW -* .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = MAX( 1, NW )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - ELSE - IWS = NW - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), T, LDT ) - IF( LEFT ) THEN -* -* H or H**T is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H**T is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H**T -* - CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, - $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, - $ WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMQR -* - END - DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) -* -* -- LAPACK auxiliary routine (version 3.3.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* Based on LAPACK DLAMCH but with Fortran 95 query functions -* See: http://www.cs.utk.edu/~luszczek/lapack/lamch.html -* and -* http://www.netlib.org/lapack-dev/lapack-coding/program-style.html#id2537289 -* July 2010 -* -* .. Scalar Arguments .. - CHARACTER CMACH -* .. -* -* Purpose -* ======= -* -* DLAMCH determines double precision machine parameters. -* -* Arguments -* ========= -* -* CMACH (input) CHARACTER*1 -* Specifies the value to be returned by DLAMCH: -* = 'E' or 'e', DLAMCH := eps -* = 'S' or 's , DLAMCH := sfmin -* = 'B' or 'b', DLAMCH := base -* = 'P' or 'p', DLAMCH := eps*base -* = 'N' or 'n', DLAMCH := t -* = 'R' or 'r', DLAMCH := rnd -* = 'M' or 'm', DLAMCH := emin -* = 'U' or 'u', DLAMCH := rmin -* = 'L' or 'l', DLAMCH := emax -* = 'O' or 'o', DLAMCH := rmax -* -* where -* -* eps = relative machine precision -* sfmin = safe minimum, such that 1/sfmin does not overflow -* base = base of the machine -* prec = eps*base -* t = number of (base) digits in the mantissa -* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise -* emin = minimum exponent before (gradual) underflow -* rmin = underflow threshold - base**(emin-1) -* emax = largest exponent before overflow -* rmax = overflow threshold - (base**emax)*(1-eps) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, - $ MINEXPONENT, RADIX, TINY -* .. -* .. Executable Statements .. -* -* -* Assume rounding, not chopping. Always. -* - RND = ONE -* - IF( ONE.EQ.RND ) THEN - EPS = EPSILON(ZERO) * 0.5 - ELSE - EPS = EPSILON(ZERO) - END IF -* - IF( LSAME( CMACH, 'E' ) ) THEN - RMACH = EPS - ELSE IF( LSAME( CMACH, 'S' ) ) THEN - SFMIN = TINY(ZERO) - SMALL = ONE / HUGE(ZERO) - IF( SMALL.GE.SFMIN ) THEN -* -* Use SMALL plus a bit, to avoid the possibility of rounding -* causing overflow when computing 1/sfmin. -* - SFMIN = SMALL*( ONE+EPS ) - END IF - RMACH = SFMIN - ELSE IF( LSAME( CMACH, 'B' ) ) THEN - RMACH = RADIX(ZERO) - ELSE IF( LSAME( CMACH, 'P' ) ) THEN - RMACH = EPS * RADIX(ZERO) - ELSE IF( LSAME( CMACH, 'N' ) ) THEN - RMACH = DIGITS(ZERO) - ELSE IF( LSAME( CMACH, 'R' ) ) THEN - RMACH = RND - ELSE IF( LSAME( CMACH, 'M' ) ) THEN - RMACH = MINEXPONENT(ZERO) - ELSE IF( LSAME( CMACH, 'U' ) ) THEN - RMACH = tiny(zero) - ELSE IF( LSAME( CMACH, 'L' ) ) THEN - RMACH = MAXEXPONENT(ZERO) - ELSE IF( LSAME( CMACH, 'O' ) ) THEN - RMACH = HUGE(ZERO) - ELSE - RMACH = ZERO - END IF -* - DLAMCH = RMACH - RETURN -* -* End of DLAMCH -* - END -************************************************************************ -* - INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER ISPEC - REAL ONE, ZERO -* .. -* -* Purpose -* ======= -* -* IEEECK is called from the ILAENV to verify that Infinity and -* possibly NaN arithmetic is safe (i.e. will not trap). -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies whether to test just for inifinity arithmetic -* or whether to test for infinity and NaN arithmetic. -* = 0: Verify infinity arithmetic only. -* = 1: Verify infinity and NaN arithmetic. -* -* ZERO (input) REAL -* Must contain the value 0.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* ONE (input) REAL -* Must contain the value 1.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* RETURN VALUE: INTEGER -* = 0: Arithmetic failed to produce the correct answers -* = 1: Arithmetic produced the correct answers -* -* ===================================================================== -* -* .. Local Scalars .. - REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, - $ NEGZRO, NEWZRO, POSINF -* .. -* .. Executable Statements .. - IEEECK = 1 -* - POSINF = ONE / ZERO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = -ONE / ZERO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGZRO = ONE / ( NEGINF+ONE ) - IF( NEGZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = ONE / NEGZRO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEWZRO = NEGZRO + ZERO - IF( NEWZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = ONE / NEWZRO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = NEGINF*POSINF - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = POSINF*POSINF - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* -* -* -* -* Return if we were only asked to check infinity arithmetic -* - IF( ISPEC.EQ.0 ) - $ RETURN -* - NAN1 = POSINF + NEGINF -* - NAN2 = POSINF / NEGINF -* - NAN3 = POSINF / POSINF -* - NAN4 = POSINF*ZERO -* - NAN5 = NEGINF*NEGZRO -* - NAN6 = NAN5*ZERO -* - IF( NAN1.EQ.NAN1 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN2.EQ.NAN2 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN3.EQ.NAN3 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN4.EQ.NAN4 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN5.EQ.NAN5 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN6.EQ.NAN6 ) THEN - IEEECK = 0 - RETURN - END IF -* - RETURN - END - INTEGER FUNCTION ILADLC( M, N, A, LDA ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.2.2) -- -* -* -- June 2010 -- -* -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ILADLC scans A for its last non-zero column. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The m by n matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( N.EQ.0 ) THEN - ILADLC = N - ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILADLC = N - ELSE -* Now scan each column from the end, returning with the first -* non-zero. - DO ILADLC = N, 1, -1 - DO I = 1, M - IF( A(I, ILADLC).NE.ZERO ) RETURN - END DO - END DO - END IF - RETURN - END - INTEGER FUNCTION ILADLR( M, N, A, LDA ) - IMPLICIT NONE -* -* -- LAPACK auxiliary routine (version 3.3.1) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -- April 2011 -- -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ILADLR scans A for its last non-zero row. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The m by n matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( M.EQ.0 ) THEN - ILADLR = M - ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILADLR = M - ELSE -* Scan up each column tracking the last zero row seen. - ILADLR = 0 - DO J = 1, N - I=M - DO WHILE ((A(I,J).NE.ZERO).AND.(I.GE.1)) - I=I-1 - ENDDO - ILADLR = MAX( ILADLR, I ) - END DO - END IF - RETURN - END - INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) -* -* -- LAPACK auxiliary routine (version 3.2.1) -- -* -* -- April 2009 -- -* -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER*( * ) NAME, OPTS - INTEGER ISPEC, N1, N2, N3, N4 -* .. -* -* Purpose -* ======= -* -* ILAENV is called from the LAPACK routines to choose problem-dependent -* parameters for the local environment. See ISPEC for a description of -* the parameters. -* -* ILAENV returns an INTEGER -* if ILAENV >= 0: ILAENV returns the value of the parameter specified -* by ISPEC -* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal -* value. -* -* This version provides a set of parameters which should give good, -* but not optimal, performance on many of the currently available -* computers. Users are encouraged to modify this subroutine to set -* the tuning parameters for their particular machine using the option -* and problem size information in the arguments. -* -* This routine will not function correctly if it is converted to all -* lower case. Converting it to all upper case is allowed. -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies the parameter to be returned as the value of -* ILAENV. -* = 1: the optimal blocksize; if this value is 1, an unblocked -* algorithm will give the best performance. -* = 2: the minimum block size for which the block routine -* should be used; if the usable block size is less than -* this value, an unblocked routine should be used. -* = 3: the crossover point (in a block routine, for N less -* than this value, an unblocked routine should be used) -* = 4: the number of shifts, used in the nonsymmetric -* eigenvalue routines (DEPRECATED) -* = 5: the minimum column dimension for blocking to be used; -* rectangular blocks must have dimension at least k by m, -* where k is given by ILAENV(2,...) and m by ILAENV(5,...) -* = 6: the crossover point for the SVD (when reducing an m by n -* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds -* this value, a QR factorization is used first to reduce -* the matrix to a triangular form.) -* = 7: the number of processors -* = 8: the crossover point for the multishift QR method -* for nonsymmetric eigenvalue problems (DEPRECATED) -* = 9: maximum size of the subproblems at the bottom of the -* computation tree in the divide-and-conquer algorithm -* (used by xGELSD and xGESDD) -* =10: ieee NaN arithmetic can be trusted not to trap -* =11: infinity arithmetic can be trusted not to trap -* 12 <= ISPEC <= 16: -* xHSEQR or one of its subroutines, -* see IPARMQ for detailed explanation -* -* NAME (input) CHARACTER*(*) -* The name of the calling subroutine, in either upper case or -* lower case. -* -* OPTS (input) CHARACTER*(*) -* The character options to the subroutine NAME, concatenated -* into a single character string. For example, UPLO = 'U', -* TRANS = 'T', and DIAG = 'N' for a triangular routine would -* be specified as OPTS = 'UTN'. -* -* N1 (input) INTEGER -* N2 (input) INTEGER -* N3 (input) INTEGER -* N4 (input) INTEGER -* Problem dimensions for the subroutine NAME; these may not all -* be required. -* -* Further Details -* =============== -* -* The following conventions have been used when calling ILAENV from the -* LAPACK routines: -* 1) OPTS is a concatenation of all of the character options to -* subroutine NAME, in the same order that they appear in the -* argument list for NAME, even if they are not used in determining -* the value of the parameter specified by ISPEC. -* 2) The problem dimensions N1, N2, N3, N4 are specified in the order -* that they appear in the argument list for NAME. N1 is used -* first, N2 second, and so on, and unused problem dimensions are -* passed a value of -1. -* 3) The parameter value returned by ILAENV is checked for validity in -* the calling subroutine. For example, ILAENV is used to retrieve -* the optimal blocksize for STRTRI as follows: -* -* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) -* IF( NB.LE.1 ) NB = MAX( 1, N ) -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IC, IZ, NB, NBMIN, NX - LOGICAL CNAME, SNAME - CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 -* .. -* .. Intrinsic Functions .. - INTRINSIC CHAR, ICHAR, INT, MIN, REAL -* .. -* .. External Functions .. - INTEGER IEEECK, IPARMQ - EXTERNAL IEEECK, IPARMQ -* .. -* .. Executable Statements .. -* - GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, - $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC -* -* Invalid value for ISPEC -* - ILAENV = -1 - RETURN -* - 10 CONTINUE -* -* Convert NAME to upper case if the first character is lower case. -* - ILAENV = 1 - SUBNAM = NAME - IC = ICHAR( SUBNAM( 1: 1 ) ) - IZ = ICHAR( 'Z' ) - IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN -* -* ASCII character set -* - IF( IC.GE.97 .AND. IC.LE.122 ) THEN - SUBNAM( 1: 1 ) = CHAR( IC-32 ) - DO 20 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( IC.GE.97 .AND. IC.LE.122 ) - $ SUBNAM( I: I ) = CHAR( IC-32 ) - 20 CONTINUE - END IF -* - ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN -* -* EBCDIC character set -* - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN - SUBNAM( 1: 1 ) = CHAR( IC+64 ) - DO 30 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: - $ I ) = CHAR( IC+64 ) - 30 CONTINUE - END IF -* - ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN -* -* Prime machines: ASCII+128 -* - IF( IC.GE.225 .AND. IC.LE.250 ) THEN - SUBNAM( 1: 1 ) = CHAR( IC-32 ) - DO 40 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( IC.GE.225 .AND. IC.LE.250 ) - $ SUBNAM( I: I ) = CHAR( IC-32 ) - 40 CONTINUE - END IF - END IF -* - C1 = SUBNAM( 1: 1 ) - SNAME = C1.EQ.'S' .OR. C1.EQ.'D' - CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' - IF( .NOT.( CNAME .OR. SNAME ) ) - $ RETURN - C2 = SUBNAM( 2: 3 ) - C3 = SUBNAM( 4: 6 ) - C4 = C3( 2: 3 ) -* - GO TO ( 50, 60, 70 )ISPEC -* - 50 CONTINUE -* -* ISPEC = 1: block size -* -* In these examples, separate code is provided for setting NB for -* real and complex. We assume that NB will take the same value in -* single or double precision. -* - NB = 1 -* - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'PO' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRF' ) THEN - NB = 64 - ELSE IF( C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - END IF - ELSE IF( C2.EQ.'GB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'PB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'TR' ) THEN - IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'LA' ) THEN - IF( C3.EQ.'UUM' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN - IF( C3.EQ.'EBZ' ) THEN - NB = 1 - END IF - END IF - ILAENV = NB - RETURN -* - 60 CONTINUE -* -* ISPEC = 2: minimum block size -* - NBMIN = 2 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. - $ 'QLF' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NBMIN = 8 - ELSE - NBMIN = 8 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - END IF - END IF - ILAENV = NBMIN - RETURN -* - 70 CONTINUE -* -* ISPEC = 3: crossover point -* - NX = 0 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. - $ 'QLF' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NX = 128 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NX = 128 - END IF - END IF - END IF - ILAENV = NX - RETURN -* - 80 CONTINUE -* -* ISPEC = 4: number of shifts (used by xHSEQR) -* - ILAENV = 6 - RETURN -* - 90 CONTINUE -* -* ISPEC = 5: minimum column dimension (not used) -* - ILAENV = 2 - RETURN -* - 100 CONTINUE -* -* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) -* - ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) - RETURN -* - 110 CONTINUE -* -* ISPEC = 7: number of processors (not used) -* - ILAENV = 1 - RETURN -* - 120 CONTINUE -* -* ISPEC = 8: crossover point for multishift (used by xHSEQR) -* - ILAENV = 50 - RETURN -* - 130 CONTINUE -* -* ISPEC = 9: maximum size of the subproblems at the bottom of the -* computation tree in the divide-and-conquer algorithm -* (used by xGELSD and xGESDD) -* - ILAENV = 25 - RETURN -* - 140 CONTINUE -* -* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap -* -* ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 1, 0.0, 1.0 ) - END IF - RETURN -* - 150 CONTINUE -* -* ISPEC = 11: infinity arithmetic can be trusted not to trap -* -* ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 0, 0.0, 1.0 ) - END IF - RETURN -* - 160 CONTINUE -* -* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. -* - ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) - RETURN -* -* End of ILAENV -* - END - INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG -* Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - INTEGER IHI, ILO, ISPEC, LWORK, N - CHARACTER NAME*( * ), OPTS*( * ) -* -* Purpose -* ======= -* -* This program sets problem and machine dependent parameters -* useful for xHSEQR and its subroutines. It is called whenever -* ILAENV is called with 12 <= ISPEC <= 16 -* -* Arguments -* ========= -* -* ISPEC (input) integer scalar -* ISPEC specifies which tunable parameter IPARMQ should -* return. -* -* ISPEC=12: (INMIN) Matrices of order nmin or less -* are sent directly to xLAHQR, the implicit -* double shift QR algorithm. NMIN must be -* at least 11. -* -* ISPEC=13: (INWIN) Size of the deflation window. -* This is best set greater than or equal to -* the number of simultaneous shifts NS. -* Larger matrices benefit from larger deflation -* windows. -* -* ISPEC=14: (INIBL) Determines when to stop nibbling and -* invest in an (expensive) multi-shift QR sweep. -* If the aggressive early deflation subroutine -* finds LD converged eigenvalues from an order -* NW deflation window and LD.GT.(NW*NIBBLE)/100, -* then the next QR sweep is skipped and early -* deflation is applied immediately to the -* remaining active diagonal block. Setting -* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a -* multi-shift QR sweep whenever early deflation -* finds a converged eigenvalue. Setting -* IPARMQ(ISPEC=14) greater than or equal to 100 -* prevents TTQRE from skipping a multi-shift -* QR sweep. -* -* ISPEC=15: (NSHFTS) The number of simultaneous shifts in -* a multi-shift QR iteration. -* -* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the -* following meanings. -* 0: During the multi-shift QR sweep, -* xLAQR5 does not accumulate reflections and -* does not use matrix-matrix multiply to -* update the far-from-diagonal matrix -* entries. -* 1: During the multi-shift QR sweep, -* xLAQR5 and/or xLAQRaccumulates reflections -* and uses -* matrix-matrix multiply to update the -* far-from-diagonal matrix entries. -* 2: During the multi-shift QR sweep. -* xLAQR5 accumulates reflections and takes -* advantage of 2-by-2 block structure during -* matrix-matrix multiplies. -* (If xTRMM is slower than xGEMM, then -* IPARMQ(ISPEC=16)=1 may be more efficient than -* IPARMQ(ISPEC=16)=2 despite the greater level of -* arithmetic work implied by the latter choice.) -* -* NAME (input) character string -* Name of the calling subroutine -* -* OPTS (input) character string -* This is a concatenation of the string arguments to -* TTQRE. -* -* N (input) integer scalar -* N is the order of the Hessenberg matrix H. -* -* ILO (input) INTEGER -* IHI (input) INTEGER -* It is assumed that H is already upper triangular -* in rows and columns 1:ILO-1 and IHI+1:N. -* -* LWORK (input) integer scalar -* The amount of workspace available. -* -* Further Details -* =============== -* -* Little is known about how best to choose these parameters. -* It is possible to use different values of the parameters -* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. -* -* It is probably best to choose different parameters for -* different matrices and different parameters at different -* times during the iteration, but this has not been -* implemented --- yet. -* -* -* The best choices of most of the parameters depend -* in an ill-understood way on the relative execution -* rate of xLAQR3 and xLAQR5 and on the nature of each -* particular eigenvalue problem. Experiment may be the -* only practical way to determine which choices are most -* effective. -* -* Following is a list of default values supplied by IPARMQ. -* These defaults may be adjusted in order to attain better -* performance in any particular computational environment. -* -* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. -* Default: 75. (Must be at least 11.) -* -* IPARMQ(ISPEC=13) Recommended deflation window size. -* This depends on ILO, IHI and NS, the -* number of simultaneous shifts returned -* by IPARMQ(ISPEC=15). The default for -* (IHI-ILO+1).LE.500 is NS. The default -* for (IHI-ILO+1).GT.500 is 3*NS/2. -* -* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. -* -* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. -* a multi-shift QR iteration. -* -* If IHI-ILO+1 is ... -* -* greater than ...but less ... the -* or equal to ... than default is -* -* 0 30 NS = 2+ -* 30 60 NS = 4+ -* 60 150 NS = 10 -* 150 590 NS = ** -* 590 3000 NS = 64 -* 3000 6000 NS = 128 -* 6000 infinity NS = 256 -* -* (+) By default matrices of this order are -* passed to the implicit double shift routine -* xLAHQR. See IPARMQ(ISPEC=12) above. These -* values of NS are used only in case of a rare -* xLAHQR failure. -* -* (**) The asterisks (**) indicate an ad-hoc -* function increasing from 10 to 64. -* -* IPARMQ(ISPEC=16) Select structured matrix multiply. -* (See ISPEC=16 above for details.) -* Default: 3. -* -* ================================================================ -* .. Parameters .. - INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 - PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, - $ ISHFTS = 15, IACC22 = 16 ) - INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP - PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, - $ NIBBLE = 14, KNWSWP = 500 ) - REAL TWO - PARAMETER ( TWO = 2.0 ) -* .. -* .. Local Scalars .. - INTEGER NH, NS -* .. -* .. Intrinsic Functions .. - INTRINSIC LOG, MAX, MOD, NINT, REAL -* .. -* .. Executable Statements .. - IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. - $ ( ISPEC.EQ.IACC22 ) ) THEN -* -* ==== Set the number simultaneous shifts ==== -* - NH = IHI - ILO + 1 - NS = 2 - IF( NH.GE.30 ) - $ NS = 4 - IF( NH.GE.60 ) - $ NS = 10 - IF( NH.GE.150 ) - $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) - IF( NH.GE.590 ) - $ NS = 64 - IF( NH.GE.3000 ) - $ NS = 128 - IF( NH.GE.6000 ) - $ NS = 256 - NS = MAX( 2, NS-MOD( NS, 2 ) ) - END IF -* - IF( ISPEC.EQ.INMIN ) THEN -* -* -* ===== Matrices of order smaller than NMIN get sent -* . to xLAHQR, the classic double shift algorithm. -* . This must be at least 11. ==== -* - IPARMQ = NMIN -* - ELSE IF( ISPEC.EQ.INIBL ) THEN -* -* ==== INIBL: skip a multi-shift qr iteration and -* . whenever aggressive early deflation finds -* . at least (NIBBLE*(window size)/100) deflations. ==== -* - IPARMQ = NIBBLE -* - ELSE IF( ISPEC.EQ.ISHFTS ) THEN -* -* ==== NSHFTS: The number of simultaneous shifts ===== -* - IPARMQ = NS -* - ELSE IF( ISPEC.EQ.INWIN ) THEN -* -* ==== NW: deflation window size. ==== -* - IF( NH.LE.KNWSWP ) THEN - IPARMQ = NS - ELSE - IPARMQ = 3*NS / 2 - END IF -* - ELSE IF( ISPEC.EQ.IACC22 ) THEN -* -* ==== IACC22: Whether to accumulate reflections -* . before updating the far-from-diagonal elements -* . and whether to use 2-by-2 block structure while -* . doing it. A small amount of work could be saved -* . by making this choice dependent also upon the -* . NH=IHI-ILO+1. -* - IPARMQ = 0 - IF( NS.GE.KACMIN ) - $ IPARMQ = 1 - IF( NS.GE.K22MIN ) - $ IPARMQ = 2 -* - ELSE -* ===== invalid value of ispec ===== - IPARMQ = -1 -* - END IF -* -* ==== End of IPARMQ ==== -* - END - diff --git a/toms1012/sample_input2d.dat b/toms1012/sample_input2d.dat deleted file mode 100644 index 1ebeed6..0000000 --- a/toms1012/sample_input2d.dat +++ /dev/null @@ -1,188 +0,0 @@ -2,43,101,1 --0.737779900597,-0.675041345605 --0.737779900597,0.587602108436 -0.524863553445,-0.675041345605 -0.524863553445,0.587602108436 --0.663506756241,0.166253571025 --0.584282068929,-0.394609706728 --0.584282068929,0.446685209901 --0.584282068929,0.586901029339 --0.425832694304,-0.534825526166 --0.425832694304,-0.464717616447 --0.425832694304,-0.184285977571 --0.425832694304,-0.0440701581327 --0.425832694304,0.0961456613055 --0.425832694304,0.236361480744 --0.425832694304,0.51679311962 --0.108933945055,-0.675041345605 --0.108933945055,-0.534825526166 --0.108933945055,-0.464717616447 --0.108933945055,-0.394609706728 --0.108933945055,-0.25439388729 --0.108933945055,-0.184285977571 --0.108933945055,-0.114178067852 --0.108933945055,-0.0440701581327 --0.108933945055,0.0961456613055 --0.108933945055,0.166253571025 --0.108933945055,0.236361480744 --0.108933945055,0.376577300182 --0.108933945055,0.51679311962 --0.108933945055,0.587602108436 -0.524863553445,-0.534825526166 -0.524863553445,-0.464717616447 -0.524863553445,-0.394609706728 -0.524863553445,-0.25439388729 -0.524863553445,-0.184285977571 -0.524863553445,-0.114178067852 -0.524863553445,-0.0440701581327 -0.524863553445,0.0961456613055 -0.524863553445,0.166253571025 -0.524863553445,0.236361480744 -0.524863553445,0.376577300182 -0.524863553445,0.446685209901 -0.524863553445,0.51679311962 -0.524863553445,0.586901029339 -296835782027 -736030395045 -1.06918217819E+016 -3.20566930178E+016 -73374496803300 -189039708822000 -273719385634000 -326069037783000 -675040018268000 -756967336463000 -914266006037000 -1.0830311159E+015 -1218388638980000 -1326756634210000 -1463454444460000 -2.5144413074E+015 -2.77933373432E+015 -2836545644680000 -3155262430390000 -3451182362430000 -3715001247780000 -3896447879110000 -4.11531577031E+015 -4745519778190000 -4840384897050000 -5228331120200000 -5481722046370000 -6250890553900000 -7367804014150000 -1.16388102101E+016 -1.11174656608E+016 -1.25221884669E+016 -1.49468718462E+016 -1.468022513E+016 -1.54642127154E+016 -1.65072763423E+016 -2.08248675151E+016 -1.86574133761E+016 -2.01386128979E+016 -2.38441779462E+016 -2.52856646169E+016 -2.56482815535E+016 -2.78334409382E+016 --0.737779900597,-0.534825526166 --0.737779900597,-0.464717616447 --0.737779900597,-0.394609706728 --0.737779900597,-0.25439388729 --0.737779900597,-0.184285977571 --0.737779900597,-0.114178067852 --0.737779900597,-0.0440701581327 --0.737779900597,0.0961456613055 --0.737779900597,0.166253571025 --0.737779900597,0.236361480744 --0.737779900597,0.376577300182 --0.737779900597,0.446685209901 --0.737779900597,0.51679311962 --0.737779900597,0.586901029339 --0.73282835764,-0.675041345605 --0.73282835764,-0.534825526166 --0.73282835764,-0.464717616447 --0.73282835764,-0.394609706728 --0.73282835764,-0.25439388729 --0.73282835764,-0.184285977571 --0.73282835764,-0.114178067852 --0.73282835764,-0.0440701581327 --0.73282835764,0.0961456613055 --0.73282835764,0.166253571025 --0.73282835764,0.236361480744 --0.73282835764,0.376577300182 --0.73282835764,0.446685209901 --0.73282835764,0.51679311962 --0.73282835764,0.586901029339 --0.73282835764,0.587602108436 --0.722925271725,-0.675041345605 --0.722925271725,-0.534825526166 --0.722925271725,-0.464717616447 --0.722925271725,-0.394609706728 --0.722925271725,-0.25439388729 --0.722925271725,-0.184285977571 --0.722925271725,-0.114178067852 --0.722925271725,-0.0440701581327 --0.722925271725,0.0961456613055 --0.722925271725,0.166253571025 --0.722925271725,0.236361480744 --0.722925271725,0.376577300182 --0.722925271725,0.446685209901 --0.722925271725,0.51679311962 --0.722925271725,0.586901029339 --0.722925271725,0.587602108436 --0.703119099897,-0.675041345605 --0.703119099897,-0.534825526166 --0.703119099897,-0.464717616447 --0.703119099897,-0.394609706728 --0.703119099897,-0.25439388729 --0.703119099897,-0.184285977571 --0.703119099897,-0.114178067852 --0.703119099897,-0.0440701581327 --0.703119099897,0.0961456613055 --0.703119099897,0.166253571025 --0.703119099897,0.236361480744 --0.703119099897,0.376577300182 --0.703119099897,0.446685209901 --0.703119099897,0.51679311962 --0.703119099897,0.586901029339 --0.703119099897,0.587602108436 --0.663506756241,-0.675041345605 --0.663506756241,-0.534825526166 --0.663506756241,-0.464717616447 --0.663506756241,-0.394609706728 --0.663506756241,-0.25439388729 --0.663506756241,-0.184285977571 --0.663506756241,-0.114178067852 --0.663506756241,-0.0440701581327 --0.663506756241,0.0961456613055 --0.663506756241,0.236361480744 --0.663506756241,0.376577300182 --0.663506756241,0.446685209901 --0.663506756241,0.51679311962 --0.663506756241,0.586901029339 --0.663506756241,0.587602108436 --0.584282068929,-0.675041345605 --0.584282068929,-0.534825526166 --0.584282068929,-0.464717616447 --0.584282068929,-0.25439388729 --0.584282068929,-0.184285977571 --0.584282068929,-0.114178067852 --0.584282068929,-0.0440701581327 --0.584282068929,0.0961456613055 --0.584282068929,0.166253571025 --0.584282068929,0.236361480744 --0.584282068929,0.376577300182 --0.584282068929,0.51679311962 --0.584282068929,0.587602108436 --0.425832694304,-0.675041345605 --0.425832694304,-0.394609706728 --0.425832694304,-0.25439388729 --0.425832694304,-0.114178067852 --0.425832694304,0.166253571025 --0.425832694304,0.376577300182 --0.425832694304,0.446685209901 --0.425832694304,0.586901029339 --0.425832694304,0.587602108436 --0.108933945055,0.446685209901 --0.108933945055,0.586901029339 diff --git a/toms1012/sample_input4d.dat b/toms1012/sample_input4d.dat deleted file mode 100644 index f786eda..0000000 --- a/toms1012/sample_input4d.dat +++ /dev/null @@ -1,1297 +0,0 @@ -4,432,432,1 --0.429559544383,-0.141336559823,-0.324322498044,-0.452914378473 --0.429559544383,-0.141336559823,-0.324322498044,0.346266169217 --0.429559544383,-0.141336559823,0.474858049646,-0.452914378473 --0.429559544383,-0.141336559823,0.474858049646,0.346266169217 -0.369621003307,-0.141336559823,-0.324322498044,-0.452914378473 -0.369621003307,-0.141336559823,-0.324322498044,0.346266169217 -0.369621003307,-0.141336559823,0.474858049646,-0.452914378473 -0.369621003307,-0.141336559823,0.474858049646,0.346266169217 -0.369621003307,0.657843987867,-0.324322498044,-0.452914378473 -0.369621003307,0.657843987867,-0.324322498044,0.346266169217 -0.369621003307,0.657843987867,0.474858049646,-0.452914378473 -0.369621003307,0.657843987867,0.474858049646,0.346266169217 --0.429559544383,-0.141336559823,-0.302384208499,-0.452914378473 --0.429559544383,-0.141336559823,-0.302384208499,0.21269962571 --0.429559544383,-0.141336559823,-0.277311877591,-0.452914378473 --0.429559544383,-0.141336559823,-0.277311877591,-0.364165844582 --0.429559544383,-0.141336559823,-0.277311877591,-0.275417310691 --0.429559544383,-0.141336559823,-0.277311877591,0.0795768248736 --0.429559544383,-0.141336559823,-0.277311877591,0.123951091819 --0.429559544383,-0.141336559823,-0.277311877591,0.21269962571 --0.429559544383,-0.141336559823,-0.277311877591,0.345822426547 --0.429559544383,-0.141336559823,-0.277311877591,0.346266169217 --0.429559544383,-0.141336559823,-0.227167215775,-0.1866687768 --0.429559544383,-0.141336559823,-0.227167215775,-0.142294509854 --0.429559544383,-0.141336559823,-0.227167215775,-0.0979202429087 --0.429559544383,-0.141336559823,-0.227167215775,-0.0535459759631 --0.429559544383,-0.141336559823,-0.227167215775,0.0352025579281 --0.429559544383,-0.141336559823,-0.227167215775,0.0795768248736 --0.429559544383,-0.141336559823,-0.227167215775,0.123951091819 --0.429559544383,-0.141336559823,-0.227167215775,0.21269962571 --0.429559544383,-0.141336559823,-0.227167215775,0.257073892656 --0.429559544383,-0.141336559823,-0.227167215775,0.301448159602 --0.429559544383,-0.141336559823,-0.227167215775,0.345822426547 --0.429559544383,-0.141336559823,-0.227167215775,0.346266169217 --0.429559544383,-0.141336559823,-0.126877892144,-0.364165844582 --0.429559544383,-0.141336559823,-0.126877892144,-0.319791577637 --0.429559544383,-0.141336559823,-0.126877892144,-0.275417310691 --0.429559544383,-0.141336559823,-0.126877892144,-0.1866687768 --0.429559544383,-0.141336559823,-0.126877892144,-0.142294509854 --0.429559544383,-0.141336559823,-0.126877892144,-0.0979202429087 --0.429559544383,-0.141336559823,-0.126877892144,-0.0535459759631 --0.429559544383,-0.141336559823,-0.126877892144,0.0352025579281 --0.429559544383,-0.141336559823,-0.126877892144,0.0795768248736 --0.429559544383,-0.141336559823,-0.126877892144,0.123951091819 --0.429559544383,-0.141336559823,-0.126877892144,0.21269962571 --0.429559544383,-0.141336559823,-0.126877892144,0.257073892656 --0.429559544383,-0.141336559823,-0.126877892144,0.301448159602 --0.429559544383,-0.141336559823,-0.126877892144,0.345822426547 --0.429559544383,-0.141336559823,-0.126877892144,0.346266169217 --0.429559544383,-0.141336559823,0.0737007551197,-0.452914378473 --0.429559544383,-0.141336559823,0.0737007551197,-0.364165844582 --0.429559544383,-0.141336559823,0.0737007551197,-0.319791577637 --0.429559544383,-0.141336559823,0.0737007551197,-0.275417310691 --0.429559544383,-0.141336559823,0.0737007551197,-0.1866687768 --0.429559544383,-0.141336559823,0.0737007551197,-0.142294509854 --0.429559544383,-0.141336559823,0.0737007551197,-0.0979202429087 --0.429559544383,-0.141336559823,0.0737007551197,-0.0535459759631 --0.429559544383,-0.141336559823,0.0737007551197,0.0352025579281 --0.429559544383,-0.141336559823,0.0737007551197,0.0795768248736 --0.429559544383,-0.141336559823,0.0737007551197,0.123951091819 --0.429559544383,-0.141336559823,0.0737007551197,0.21269962571 --0.429559544383,-0.141336559823,0.0737007551197,0.257073892656 --0.429559544383,-0.141336559823,0.0737007551197,0.301448159602 --0.429559544383,-0.141336559823,0.0737007551197,0.345822426547 --0.429559544383,-0.141336559823,0.0737007551197,0.346266169217 --0.429559544383,-0.141336559823,0.474858049646,-0.364165844582 --0.429559544383,-0.141336559823,0.474858049646,-0.319791577637 --0.429559544383,-0.141336559823,0.474858049646,-0.275417310691 --0.429559544383,-0.141336559823,0.474858049646,-0.1866687768 --0.429559544383,-0.141336559823,0.474858049646,-0.142294509854 --0.429559544383,-0.141336559823,0.474858049646,-0.0979202429087 --0.429559544383,-0.141336559823,0.474858049646,-0.0535459759631 --0.429559544383,-0.141336559823,0.474858049646,0.0352025579281 --0.429559544383,-0.141336559823,0.474858049646,0.0795768248736 --0.429559544383,-0.141336559823,0.474858049646,0.123951091819 --0.429559544383,-0.141336559823,0.474858049646,0.21269962571 --0.429559544383,-0.141336559823,0.474858049646,0.257073892656 --0.429559544383,-0.141336559823,0.474858049646,0.301448159602 --0.429559544383,-0.141336559823,0.474858049646,0.345822426547 --0.269723434845,-0.141336559823,-0.32118845668,0.21269962571 --0.269723434845,-0.141336559823,-0.314920373953,0.0352025579281 --0.269723434845,-0.141336559823,-0.314920373953,0.0795768248736 --0.269723434845,-0.141336559823,-0.314920373953,0.301448159602 --0.269723434845,-0.141336559823,-0.302384208499,-0.364165844582 --0.269723434845,-0.141336559823,-0.302384208499,-0.275417310691 --0.269723434845,-0.141336559823,-0.302384208499,-0.1866687768 --0.269723434845,-0.141336559823,-0.302384208499,-0.0979202429087 --0.269723434845,-0.141336559823,-0.302384208499,0.0795768248736 --0.269723434845,-0.141336559823,-0.302384208499,0.301448159602 --0.269723434845,-0.141336559823,-0.277311877591,-0.452914378473 --0.269723434845,-0.141336559823,-0.277311877591,-0.275417310691 --0.269723434845,-0.141336559823,-0.277311877591,-0.142294509854 --0.269723434845,-0.141336559823,-0.277311877591,-0.0979202429087 --0.269723434845,-0.141336559823,-0.277311877591,0.0352025579281 --0.269723434845,-0.141336559823,-0.277311877591,0.0795768248736 --0.269723434845,-0.141336559823,-0.277311877591,0.123951091819 --0.269723434845,-0.141336559823,-0.277311877591,0.21269962571 --0.269723434845,-0.141336559823,-0.277311877591,0.257073892656 --0.269723434845,-0.141336559823,-0.277311877591,0.345822426547 --0.269723434845,-0.141336559823,-0.277311877591,0.346266169217 --0.269723434845,-0.141336559823,-0.227167215775,-0.452914378473 --0.269723434845,-0.141336559823,-0.227167215775,-0.364165844582 --0.269723434845,-0.141336559823,-0.227167215775,-0.319791577637 --0.269723434845,-0.141336559823,-0.227167215775,-0.275417310691 --0.269723434845,-0.141336559823,-0.227167215775,-0.0979202429087 --0.269723434845,-0.141336559823,-0.227167215775,-0.0535459759631 --0.269723434845,-0.141336559823,-0.227167215775,0.0352025579281 --0.269723434845,-0.141336559823,-0.227167215775,0.0795768248736 --0.269723434845,-0.141336559823,-0.227167215775,0.123951091819 --0.269723434845,-0.141336559823,-0.227167215775,0.21269962571 --0.269723434845,-0.141336559823,-0.227167215775,0.257073892656 --0.269723434845,-0.141336559823,-0.227167215775,0.301448159602 --0.269723434845,-0.141336559823,-0.227167215775,0.345822426547 --0.269723434845,-0.141336559823,-0.227167215775,0.346266169217 --0.269723434845,-0.141336559823,-0.126877892144,-0.452914378473 --0.269723434845,-0.141336559823,-0.126877892144,-0.364165844582 --0.269723434845,-0.141336559823,-0.126877892144,-0.319791577637 --0.269723434845,-0.141336559823,-0.126877892144,-0.275417310691 --0.269723434845,-0.141336559823,-0.126877892144,-0.1866687768 --0.269723434845,-0.141336559823,-0.126877892144,-0.142294509854 --0.269723434845,-0.141336559823,-0.126877892144,-0.0979202429087 --0.269723434845,-0.141336559823,-0.126877892144,-0.0535459759631 --0.269723434845,-0.141336559823,-0.126877892144,0.0352025579281 --0.269723434845,-0.141336559823,-0.126877892144,0.0795768248736 --0.269723434845,-0.141336559823,-0.126877892144,0.123951091819 --0.269723434845,-0.141336559823,-0.126877892144,0.21269962571 --0.269723434845,-0.141336559823,-0.126877892144,0.257073892656 --0.269723434845,-0.141336559823,-0.126877892144,0.301448159602 --0.269723434845,-0.141336559823,-0.126877892144,0.345822426547 --0.269723434845,-0.141336559823,-0.126877892144,0.346266169217 --0.269723434845,-0.141336559823,0.0737007551197,-0.452914378473 --0.269723434845,-0.141336559823,0.0737007551197,-0.364165844582 --0.269723434845,-0.141336559823,0.0737007551197,-0.319791577637 --0.269723434845,-0.141336559823,0.0737007551197,-0.275417310691 --0.269723434845,-0.141336559823,0.0737007551197,-0.1866687768 --0.269723434845,-0.141336559823,0.0737007551197,-0.142294509854 --0.269723434845,-0.141336559823,0.0737007551197,-0.0979202429087 --0.269723434845,-0.141336559823,0.0737007551197,-0.0535459759631 --0.269723434845,-0.141336559823,0.0737007551197,0.0352025579281 --0.269723434845,-0.141336559823,0.0737007551197,0.0795768248736 --0.269723434845,-0.141336559823,0.0737007551197,0.123951091819 --0.269723434845,-0.141336559823,0.0737007551197,0.21269962571 --0.269723434845,-0.141336559823,0.0737007551197,0.257073892656 --0.269723434845,-0.141336559823,0.0737007551197,0.301448159602 --0.269723434845,-0.141336559823,0.0737007551197,0.345822426547 --0.269723434845,-0.141336559823,0.0737007551197,0.346266169217 --0.269723434845,-0.141336559823,0.474858049646,-0.452914378473 --0.269723434845,-0.141336559823,0.474858049646,-0.364165844582 --0.269723434845,-0.141336559823,0.474858049646,-0.319791577637 --0.269723434845,-0.141336559823,0.474858049646,-0.275417310691 --0.269723434845,-0.141336559823,0.474858049646,-0.1866687768 --0.269723434845,-0.141336559823,0.474858049646,-0.142294509854 --0.269723434845,-0.141336559823,0.474858049646,-0.0979202429087 --0.269723434845,-0.141336559823,0.474858049646,-0.0535459759631 --0.269723434845,-0.141336559823,0.474858049646,0.0352025579281 --0.269723434845,-0.141336559823,0.474858049646,0.0795768248736 --0.269723434845,-0.141336559823,0.474858049646,0.123951091819 --0.269723434845,-0.141336559823,0.474858049646,0.21269962571 --0.269723434845,-0.141336559823,0.474858049646,0.257073892656 --0.269723434845,-0.141336559823,0.474858049646,0.301448159602 --0.269723434845,-0.141336559823,0.474858049646,0.345822426547 --0.269723434845,-0.141336559823,0.474858049646,0.346266169217 --0.269723434845,0.018499549715,-0.324322498044,-0.452914378473 --0.269723434845,0.018499549715,-0.314920373953,0.0795768248736 --0.269723434845,0.018499549715,-0.314920373953,0.301448159602 --0.269723434845,0.018499549715,-0.314920373953,0.346266169217 --0.269723434845,0.018499549715,-0.302384208499,-0.452914378473 --0.269723434845,0.018499549715,-0.302384208499,0.0795768248736 --0.269723434845,0.018499549715,-0.302384208499,0.21269962571 --0.269723434845,0.018499549715,-0.302384208499,0.345822426547 --0.269723434845,0.018499549715,-0.277311877591,-0.452914378473 --0.269723434845,0.018499549715,-0.277311877591,-0.364165844582 --0.269723434845,0.018499549715,-0.277311877591,-0.275417310691 --0.269723434845,0.018499549715,-0.277311877591,-0.0979202429087 --0.269723434845,0.018499549715,-0.277311877591,0.0795768248736 --0.269723434845,0.018499549715,-0.277311877591,0.123951091819 --0.269723434845,0.018499549715,-0.277311877591,0.21269962571 --0.269723434845,0.018499549715,-0.277311877591,0.301448159602 --0.269723434845,0.018499549715,-0.277311877591,0.345822426547 --0.269723434845,0.018499549715,-0.227167215775,-0.452914378473 --0.269723434845,0.018499549715,-0.227167215775,-0.364165844582 --0.269723434845,0.018499549715,-0.227167215775,-0.319791577637 --0.269723434845,0.018499549715,-0.227167215775,-0.275417310691 --0.269723434845,0.018499549715,-0.227167215775,-0.1866687768 --0.269723434845,0.018499549715,-0.227167215775,-0.142294509854 --0.269723434845,0.018499549715,-0.227167215775,-0.0979202429087 --0.269723434845,0.018499549715,-0.227167215775,-0.0535459759631 --0.269723434845,0.018499549715,-0.227167215775,0.0352025579281 --0.269723434845,0.018499549715,-0.227167215775,0.0795768248736 --0.269723434845,0.018499549715,-0.227167215775,0.257073892656 --0.269723434845,0.018499549715,-0.227167215775,0.301448159602 --0.269723434845,0.018499549715,-0.227167215775,0.345822426547 --0.269723434845,0.018499549715,-0.227167215775,0.346266169217 --0.269723434845,0.018499549715,-0.126877892144,-0.452914378473 --0.269723434845,0.018499549715,-0.126877892144,-0.364165844582 --0.269723434845,0.018499549715,-0.126877892144,-0.319791577637 --0.269723434845,0.018499549715,-0.126877892144,-0.275417310691 --0.269723434845,0.018499549715,-0.126877892144,-0.1866687768 --0.269723434845,0.018499549715,-0.126877892144,-0.142294509854 --0.269723434845,0.018499549715,-0.126877892144,-0.0979202429087 --0.269723434845,0.018499549715,-0.126877892144,-0.0535459759631 --0.269723434845,0.018499549715,-0.126877892144,0.0352025579281 --0.269723434845,0.018499549715,-0.126877892144,0.0795768248736 --0.269723434845,0.018499549715,-0.126877892144,0.123951091819 --0.269723434845,0.018499549715,-0.126877892144,0.21269962571 --0.269723434845,0.018499549715,-0.126877892144,0.257073892656 --0.269723434845,0.018499549715,-0.126877892144,0.301448159602 --0.269723434845,0.018499549715,-0.126877892144,0.345822426547 --0.269723434845,0.018499549715,-0.126877892144,0.346266169217 --0.269723434845,0.018499549715,0.0737007551197,-0.452914378473 --0.269723434845,0.018499549715,0.0737007551197,-0.319791577637 --0.269723434845,0.018499549715,0.0737007551197,-0.275417310691 --0.269723434845,0.018499549715,0.0737007551197,-0.1866687768 --0.269723434845,0.018499549715,0.0737007551197,-0.142294509854 --0.269723434845,0.018499549715,0.0737007551197,-0.0979202429087 --0.269723434845,0.018499549715,0.0737007551197,-0.0535459759631 --0.269723434845,0.018499549715,0.0737007551197,0.0352025579281 --0.269723434845,0.018499549715,0.0737007551197,0.0795768248736 --0.269723434845,0.018499549715,0.0737007551197,0.123951091819 --0.269723434845,0.018499549715,0.0737007551197,0.21269962571 --0.269723434845,0.018499549715,0.0737007551197,0.257073892656 --0.269723434845,0.018499549715,0.0737007551197,0.301448159602 --0.269723434845,0.018499549715,0.0737007551197,0.345822426547 --0.269723434845,0.018499549715,0.0737007551197,0.346266169217 --0.269723434845,0.018499549715,0.474858049646,-0.452914378473 --0.269723434845,0.018499549715,0.474858049646,-0.364165844582 --0.269723434845,0.018499549715,0.474858049646,-0.319791577637 --0.269723434845,0.018499549715,0.474858049646,-0.275417310691 --0.269723434845,0.018499549715,0.474858049646,-0.1866687768 --0.269723434845,0.018499549715,0.474858049646,-0.142294509854 --0.269723434845,0.018499549715,0.474858049646,-0.0979202429087 --0.269723434845,0.018499549715,0.474858049646,-0.0535459759631 --0.269723434845,0.018499549715,0.474858049646,0.0352025579281 --0.269723434845,0.018499549715,0.474858049646,0.0795768248736 --0.269723434845,0.018499549715,0.474858049646,0.123951091819 --0.269723434845,0.018499549715,0.474858049646,0.21269962571 --0.269723434845,0.018499549715,0.474858049646,0.257073892656 --0.269723434845,0.018499549715,0.474858049646,0.301448159602 --0.269723434845,0.018499549715,0.474858049646,0.345822426547 --0.269723434845,0.018499549715,0.474858049646,0.346266169217 -0.369621003307,-0.141336559823,-0.314920373953,0.257073892656 -0.369621003307,-0.141336559823,-0.302384208499,-0.1866687768 -0.369621003307,-0.141336559823,-0.302384208499,0.0352025579281 -0.369621003307,-0.141336559823,-0.302384208499,0.0795768248736 -0.369621003307,-0.141336559823,-0.302384208499,0.21269962571 -0.369621003307,-0.141336559823,-0.302384208499,0.345822426547 -0.369621003307,-0.141336559823,-0.277311877591,-0.452914378473 -0.369621003307,-0.141336559823,-0.277311877591,-0.1866687768 -0.369621003307,-0.141336559823,-0.277311877591,-0.142294509854 -0.369621003307,-0.141336559823,-0.277311877591,-0.0979202429087 -0.369621003307,-0.141336559823,-0.277311877591,-0.0535459759631 -0.369621003307,-0.141336559823,-0.277311877591,0.0352025579281 -0.369621003307,-0.141336559823,-0.277311877591,0.123951091819 -0.369621003307,-0.141336559823,-0.277311877591,0.21269962571 -0.369621003307,-0.141336559823,-0.277311877591,0.257073892656 -0.369621003307,-0.141336559823,-0.277311877591,0.301448159602 -0.369621003307,-0.141336559823,-0.277311877591,0.345822426547 -0.369621003307,-0.141336559823,-0.227167215775,-0.452914378473 -0.369621003307,-0.141336559823,-0.227167215775,-0.364165844582 -0.369621003307,-0.141336559823,-0.227167215775,-0.319791577637 -0.369621003307,-0.141336559823,-0.227167215775,-0.275417310691 -0.369621003307,-0.141336559823,-0.227167215775,-0.1866687768 -0.369621003307,-0.141336559823,-0.227167215775,-0.0979202429087 -0.369621003307,-0.141336559823,-0.227167215775,-0.0535459759631 -0.369621003307,-0.141336559823,-0.227167215775,0.0352025579281 -0.369621003307,-0.141336559823,-0.227167215775,0.0795768248736 -0.369621003307,-0.141336559823,-0.227167215775,0.123951091819 -0.369621003307,-0.141336559823,-0.227167215775,0.21269962571 -0.369621003307,-0.141336559823,-0.227167215775,0.257073892656 -0.369621003307,-0.141336559823,-0.227167215775,0.345822426547 -0.369621003307,-0.141336559823,-0.227167215775,0.346266169217 -0.369621003307,-0.141336559823,-0.126877892144,-0.452914378473 -0.369621003307,-0.141336559823,-0.126877892144,-0.364165844582 -0.369621003307,-0.141336559823,-0.126877892144,-0.319791577637 -0.369621003307,-0.141336559823,-0.126877892144,-0.275417310691 -0.369621003307,-0.141336559823,-0.126877892144,-0.1866687768 -0.369621003307,-0.141336559823,-0.126877892144,-0.142294509854 -0.369621003307,-0.141336559823,-0.126877892144,-0.0979202429087 -0.369621003307,-0.141336559823,-0.126877892144,-0.0535459759631 -0.369621003307,-0.141336559823,-0.126877892144,0.0795768248736 -0.369621003307,-0.141336559823,-0.126877892144,0.123951091819 -0.369621003307,-0.141336559823,-0.126877892144,0.21269962571 -0.369621003307,-0.141336559823,-0.126877892144,0.257073892656 -0.369621003307,-0.141336559823,-0.126877892144,0.301448159602 -0.369621003307,-0.141336559823,-0.126877892144,0.345822426547 -0.369621003307,-0.141336559823,-0.126877892144,0.346266169217 -0.369621003307,-0.141336559823,0.0737007551197,-0.452914378473 -0.369621003307,-0.141336559823,0.0737007551197,-0.364165844582 -0.369621003307,-0.141336559823,0.0737007551197,-0.319791577637 -0.369621003307,-0.141336559823,0.0737007551197,-0.275417310691 -0.369621003307,-0.141336559823,0.0737007551197,-0.1866687768 -0.369621003307,-0.141336559823,0.0737007551197,-0.142294509854 -0.369621003307,-0.141336559823,0.0737007551197,-0.0979202429087 -0.369621003307,-0.141336559823,0.0737007551197,-0.0535459759631 -0.369621003307,-0.141336559823,0.0737007551197,0.0352025579281 -0.369621003307,-0.141336559823,0.0737007551197,0.0795768248736 -0.369621003307,-0.141336559823,0.0737007551197,0.123951091819 -0.369621003307,-0.141336559823,0.0737007551197,0.21269962571 -0.369621003307,-0.141336559823,0.0737007551197,0.257073892656 -0.369621003307,-0.141336559823,0.0737007551197,0.301448159602 -0.369621003307,-0.141336559823,0.0737007551197,0.345822426547 -0.369621003307,-0.141336559823,0.0737007551197,0.346266169217 -0.369621003307,-0.141336559823,0.474858049646,-0.364165844582 -0.369621003307,-0.141336559823,0.474858049646,-0.319791577637 -0.369621003307,-0.141336559823,0.474858049646,-0.275417310691 -0.369621003307,-0.141336559823,0.474858049646,-0.1866687768 -0.369621003307,-0.141336559823,0.474858049646,-0.142294509854 -0.369621003307,-0.141336559823,0.474858049646,-0.0979202429087 -0.369621003307,-0.141336559823,0.474858049646,-0.0535459759631 -0.369621003307,-0.141336559823,0.474858049646,0.0352025579281 -0.369621003307,-0.141336559823,0.474858049646,0.0795768248736 -0.369621003307,-0.141336559823,0.474858049646,0.123951091819 -0.369621003307,-0.141336559823,0.474858049646,0.21269962571 -0.369621003307,-0.141336559823,0.474858049646,0.257073892656 -0.369621003307,-0.141336559823,0.474858049646,0.301448159602 -0.369621003307,-0.141336559823,0.474858049646,0.345822426547 -0.369621003307,0.018499549715,-0.32118845668,-0.452914378473 -0.369621003307,0.018499549715,-0.32118845668,-0.1866687768 -0.369621003307,0.018499549715,-0.314920373953,0.0795768248736 -0.369621003307,0.018499549715,-0.302384208499,-0.0535459759631 -0.369621003307,0.018499549715,-0.302384208499,0.0795768248736 -0.369621003307,0.018499549715,-0.277311877591,-0.452914378473 -0.369621003307,0.018499549715,-0.277311877591,-0.1866687768 -0.369621003307,0.018499549715,-0.277311877591,-0.142294509854 -0.369621003307,0.018499549715,-0.277311877591,-0.0979202429087 -0.369621003307,0.018499549715,-0.277311877591,0.0795768248736 -0.369621003307,0.018499549715,-0.277311877591,0.123951091819 -0.369621003307,0.018499549715,-0.277311877591,0.301448159602 -0.369621003307,0.018499549715,-0.227167215775,-0.452914378473 -0.369621003307,0.018499549715,-0.227167215775,-0.364165844582 -0.369621003307,0.018499549715,-0.227167215775,-0.319791577637 -0.369621003307,0.018499549715,-0.227167215775,-0.275417310691 -0.369621003307,0.018499549715,-0.227167215775,-0.1866687768 -0.369621003307,0.018499549715,-0.227167215775,-0.142294509854 -0.369621003307,0.018499549715,-0.227167215775,-0.0979202429087 -0.369621003307,0.018499549715,-0.227167215775,0.0352025579281 -0.369621003307,0.018499549715,-0.227167215775,0.0795768248736 -0.369621003307,0.018499549715,-0.227167215775,0.123951091819 -0.369621003307,0.018499549715,-0.227167215775,0.257073892656 -0.369621003307,0.018499549715,-0.227167215775,0.301448159602 -0.369621003307,0.018499549715,-0.227167215775,0.345822426547 -0.369621003307,0.018499549715,-0.227167215775,0.346266169217 -0.369621003307,0.018499549715,-0.126877892144,-0.452914378473 -0.369621003307,0.018499549715,-0.126877892144,-0.364165844582 -0.369621003307,0.018499549715,-0.126877892144,-0.319791577637 -0.369621003307,0.018499549715,-0.126877892144,-0.275417310691 -0.369621003307,0.018499549715,-0.126877892144,-0.1866687768 -0.369621003307,0.018499549715,-0.126877892144,-0.142294509854 -0.369621003307,0.018499549715,-0.126877892144,-0.0979202429087 -0.369621003307,0.018499549715,-0.126877892144,-0.0535459759631 -0.369621003307,0.018499549715,-0.126877892144,0.0352025579281 -0.369621003307,0.018499549715,-0.126877892144,0.0795768248736 -0.369621003307,0.018499549715,-0.126877892144,0.123951091819 -0.369621003307,0.018499549715,-0.126877892144,0.21269962571 -0.369621003307,0.018499549715,-0.126877892144,0.257073892656 -0.369621003307,0.018499549715,-0.126877892144,0.301448159602 -0.369621003307,0.018499549715,-0.126877892144,0.345822426547 -0.369621003307,0.018499549715,-0.126877892144,0.346266169217 -0.369621003307,0.018499549715,0.0737007551197,-0.452914378473 -0.369621003307,0.018499549715,0.0737007551197,-0.364165844582 -0.369621003307,0.018499549715,0.0737007551197,-0.319791577637 -0.369621003307,0.018499549715,0.0737007551197,-0.275417310691 -0.369621003307,0.018499549715,0.0737007551197,-0.1866687768 -0.369621003307,0.018499549715,0.0737007551197,-0.142294509854 -0.369621003307,0.018499549715,0.0737007551197,-0.0979202429087 -0.369621003307,0.018499549715,0.0737007551197,-0.0535459759631 -0.369621003307,0.018499549715,0.0737007551197,0.0352025579281 -0.369621003307,0.018499549715,0.0737007551197,0.0795768248736 -0.369621003307,0.018499549715,0.0737007551197,0.123951091819 -0.369621003307,0.018499549715,0.0737007551197,0.21269962571 -0.369621003307,0.018499549715,0.0737007551197,0.257073892656 -0.369621003307,0.018499549715,0.0737007551197,0.301448159602 -0.369621003307,0.018499549715,0.0737007551197,0.345822426547 -0.369621003307,0.018499549715,0.0737007551197,0.346266169217 -0.369621003307,0.018499549715,0.474858049646,-0.452914378473 -0.369621003307,0.018499549715,0.474858049646,-0.364165844582 -0.369621003307,0.018499549715,0.474858049646,-0.319791577637 -0.369621003307,0.018499549715,0.474858049646,-0.275417310691 -0.369621003307,0.018499549715,0.474858049646,-0.1866687768 -0.369621003307,0.018499549715,0.474858049646,-0.142294509854 -0.369621003307,0.018499549715,0.474858049646,-0.0979202429087 -0.369621003307,0.018499549715,0.474858049646,-0.0535459759631 -0.369621003307,0.018499549715,0.474858049646,0.0352025579281 -0.369621003307,0.018499549715,0.474858049646,0.0795768248736 -0.369621003307,0.018499549715,0.474858049646,0.123951091819 -0.369621003307,0.018499549715,0.474858049646,0.21269962571 -0.369621003307,0.018499549715,0.474858049646,0.257073892656 -0.369621003307,0.018499549715,0.474858049646,0.301448159602 -0.369621003307,0.018499549715,0.474858049646,0.345822426547 -0.369621003307,0.018499549715,0.474858049646,0.346266169217 -0.369621003307,0.657843987867,-0.314920373953,-0.142294509854 -0.369621003307,0.657843987867,-0.302384208499,-0.275417310691 -0.369621003307,0.657843987867,-0.227167215775,0.0352025579281 -0.369621003307,0.657843987867,-0.227167215775,0.0795768248736 -0.369621003307,0.657843987867,-0.227167215775,0.21269962571 -0.369621003307,0.657843987867,-0.227167215775,0.257073892656 -0.369621003307,0.657843987867,-0.227167215775,0.345822426547 -0.369621003307,0.657843987867,-0.126877892144,-0.1866687768 -0.369621003307,0.657843987867,-0.126877892144,-0.0979202429087 -0.369621003307,0.657843987867,-0.126877892144,0.0795768248736 -0.369621003307,0.657843987867,-0.126877892144,0.123951091819 -0.369621003307,0.657843987867,-0.126877892144,0.21269962571 -0.369621003307,0.657843987867,-0.126877892144,0.257073892656 -0.369621003307,0.657843987867,-0.126877892144,0.301448159602 -0.369621003307,0.657843987867,-0.126877892144,0.346266169217 -0.369621003307,0.657843987867,0.0737007551197,-0.364165844582 -0.369621003307,0.657843987867,0.0737007551197,-0.319791577637 -0.369621003307,0.657843987867,0.0737007551197,-0.275417310691 -0.369621003307,0.657843987867,0.0737007551197,-0.142294509854 -0.369621003307,0.657843987867,0.0737007551197,-0.0979202429087 -0.369621003307,0.657843987867,0.0737007551197,-0.0535459759631 -0.369621003307,0.657843987867,0.0737007551197,0.0352025579281 -0.369621003307,0.657843987867,0.0737007551197,0.0795768248736 -0.369621003307,0.657843987867,0.0737007551197,0.123951091819 -0.369621003307,0.657843987867,0.0737007551197,0.21269962571 -0.369621003307,0.657843987867,0.0737007551197,0.257073892656 -0.369621003307,0.657843987867,0.0737007551197,0.301448159602 -0.369621003307,0.657843987867,0.0737007551197,0.346266169217 -0.369621003307,0.657843987867,0.474858049646,-0.364165844582 -0.369621003307,0.657843987867,0.474858049646,-0.319791577637 -0.369621003307,0.657843987867,0.474858049646,-0.275417310691 -0.369621003307,0.657843987867,0.474858049646,-0.1866687768 -0.369621003307,0.657843987867,0.474858049646,-0.142294509854 -0.369621003307,0.657843987867,0.474858049646,-0.0979202429087 -0.369621003307,0.657843987867,0.474858049646,-0.0535459759631 -0.369621003307,0.657843987867,0.474858049646,0.0352025579281 -0.369621003307,0.657843987867,0.474858049646,0.0795768248736 -0.369621003307,0.657843987867,0.474858049646,0.123951091819 -0.369621003307,0.657843987867,0.474858049646,0.21269962571 -0.369621003307,0.657843987867,0.474858049646,0.257073892656 -0.369621003307,0.657843987867,0.474858049646,0.301448159602 -0.369621003307,0.657843987867,0.474858049646,0.345822426547 -54123792898.5 -121470858147 -3638106285000000 -1.60756296822E+016 -608968852347 -2109464220090 -1.95114323448E+016 -4.79511015336E+016 -71978621444.8 -171760606787 -213930254338000 -2260365986250000 -4952124766050 -12320033283100 -18142207372800 -23349208587600 -27139210849700 -45095480912600 -45959950912100 -51163249783600 -42594030297100 -50460588023300 -117020581223000 -124276974592000 -135657389827000 -134058184922000 -155909903633000 -158623679039000 -149101586975000 -170110125803000 -189379130153000 -202649417664000 -211606038624000 -192221177785000 -310890509435000 -343863284608000 -325678957772000 -430809541156000 -509621237708000 -423033880026000 -587071910573000 -680623907917000 -744742195421000 -795203232880000 -936678892190000 -881246682507000 -942993570599000 -955993905096000 -860542692784000 -1039364661380000 -1245405462050000 -1297388336310000 -1370245414670000 -1663128355590000 -1814361376710000 -2105318599640000 -2100298307320000 -2599649103740000 -2578738300900000 -3025342943800000 -3135923494500000 -3564861626750000 -3570025096130000 -3686213190440000 -4669723123710000 -4684898895170000 -4826719683910000 -5389749756370000 -6044534351550000 -6851325747950000 -7734567028680000 -7779297080670000 -9.30286332418E+015 -1.00926858565E+016 -1.05522151095E+016 -1.21982910604E+016 -1.2609992587E+016 -1.33405755608E+016 -1.42671665485E+016 -4285579243840 -16084877279900 -13277413905400 -17174788896100 -28180447438100 -32138189428900 -33160385962500 -36238363635100 -38751306559100 -48268216906400 -82569478769100 -92601210196700 -106956785402000 -113490453007000 -127675249201000 -131124594596000 -128763881757000 -141227807849000 -121464378127000 -143027796318000 -137027644341000 -289027586148000 -296147332944000 -303981082985000 -336882250985000 -366369655254000 -351465670160000 -363887455886000 -385379497093000 -389405201045000 -426642309866000 -383576600737000 -403423009896000 -466777994043000 -393024969784000 -1.07529193278E+015 -1212290395850000 -1360495959340000 -1267032305850000 -1579946207100000 -1682730063730000 -1837083159410000 -1952434534600000 -2258066181040000 -2199017638930000 -2369976083480000 -2508934799420000 -2615627160430000 -2467736541880000 -2311519439160000 -2512342637980000 -4821893659190000 -5211870731540000 -5108186953080000 -5880905088600000 -6409003486990000 -7212228267580000 -7301329218060000 -8120246131829999 -8917162511430000 -9.44600159965E+015 -9.92519305348E+015 -1.06847967479E+016 -1.11602461031E+016 -1.16605949281E+016 -1.2404906342E+016 -1.47082922807E+016 -1.9334186207E+016 -2.13511675373E+016 -2.14548308013E+016 -2.2859694152E+016 -2.59389616184E+016 -2.87801886438E+016 -2.78806945582E+016 -3.01488266172E+016 -3.64364012616E+016 -3.25456520238E+016 -3.47706674567E+016 -4.17357684136E+016 -4.28330927938E+016 -4.61746688249E+016 -4.68746738207E+016 -5.86310092028E+016 -161313172246 -6146526348210 -7100908376540 -8894783132820 -9759943236600 -21423689301300 -29089817483500 -34093380254800 -35164311442600 -43848080490600 -53886899790600 -67874183459300 -106021835044000 -77891036339500 -99061284120300 -100403765820000 -93645420902800 -144469815731000 -179151679296000 -160491636495000 -194372691490000 -217725481323000 -264204514987000 -273939300389000 -284658524669000 -290171264538000 -297842220440000 -349831569845000 -353265521656000 -308013338658000 -386805934395000 -604122205000000 -722717949023000 -749850832551000 -824653093717000 -941936090972000 -1008413510510000 -1.08548059417E+015 -1.09829839811E+015 -1462322494640000 -1586488666570000 -1726228067520000 -1923715305150000 -1419911971280000 -1716396258210000 -1684446185460000 -1451929761320000 -2376387855790000 -2649902169240000 -3066230645040000 -3726146925770000 -4030518397640000 -4059079175860000 -4500661601090000 -5772453637770000 -6007838111710000 -6815348851990000 -7616939522400000 -8312821381450000 -8738898800779999 -9.11630169607E+015 -1.09835614115E+016 -8343780006159999 -1.08306165432E+016 -1.24988238013E+016 -1.3468271848E+016 -1.59065184514E+016 -1.75313776237E+016 -1.76683606367E+016 -1.9866608854E+016 -2.55440361956E+016 -2.5635755578E+016 -2.68937730675E+016 -3.1368597008E+016 -3.39406468359E+016 -3.79073721256E+016 -3.71035574968E+016 -4.73307069277E+016 -14548576521000 -22617940609900 -30416035115500 -24369589167900 -25521710913900 -26256508403600 -70613243515300 -75711163713700 -88667662560800 -78846150858700 -101304530408000 -73820439039100 -86134451492900 -97120102547600 -107937470928000 -76772646861400 -95768123137600 -259824500199000 -259036048936000 -317361440008000 -280161847991000 -357554600763000 -354835053285000 -334707061497000 -296837869770000 -356701295781000 -355796792955000 -435834817407000 -348390160037000 -570792101029000 -441676120624000 -1243375266240000 -1.07168673783E+015 -1338815069960000 -1335943361720000 -1409272934510000 -1293485118490000 -1441102243750000 -1699362645320000 -1958946332550000 -1993752638680000 -1714871826870000 -1644847813380000 -2040549880390000 -1.95324833727E+015 -1835901040890000 -4077632427900000 -4889358610380000 -4697639417870000 -5135152422500000 -5000526808520000 -5831774490310000 -5605058618770000 -5824399422830000 -6364100327060000 -6532097085870000 -7046024070610000 -7058208648170000 -8823823172159999 -8565404304579999 -7429792866730000 -8135844935040000 -2.10475722875E+016 -1.71297623448E+016 -2.17527304455E+016 -2.62743616984E+016 -2.0605339779E+016 -2.45471732842E+016 -2.66092897977E+016 -3.23551690226E+016 -2.46590658581E+016 -2.93431136321E+016 -3.70602446674E+016 -3.96026518214E+016 -3.68405194831E+016 -4.41958125837E+016 -1756374854070 -2556174983140 -8111595952740 -19832031992500 -11140556807000 -40621373640000 -63844995591500 -58316526435100 -49282223580700 -57328401189200 -51861080687500 -55613140260100 -132176990525000 -200313850588000 -174859753820000 -187684112868000 -190568512012000 -238351890972000 -185145019845000 -262597022284000 -233368141744000 -292675777437000 -305566175200000 -247592610994000 -314860222428000 -286685200916000 -740023584612000 -686988468141000 -695786792995000 -816213001296000 -915602863083000 -878027958723000 -888582874165000 -974544517036000 -868889259897000 -1182941925080000 -963103253627000 -1262014020880000 -1146522461310000 -1386542698880000 -1198601438000000 -1314124018070000 -2725958694180000 -2475524399380000 -3041646727840000 -3292886381200000 -3700247028600000 -3161457499880000 -3898961472050000 -3698701351470000 -4407324534340000 -4.08190725049E+015 -4186550068870000 -3926453399800000 -5392945300410000 -4435321286360000 -5047417285370000 -5054628605600000 -1.3109495594E+016 -1.09403912425E+016 -9.99676438926E+015 -1.0767202472E+016 -1.43210146701E+016 -1.35894311704E+016 -1.3422289038E+016 -1.27240570228E+016 -1.97166329127E+016 -1.75182168132E+016 -1.85349216508E+016 -1.91821683896E+016 -2.03133755825E+016 -1.81906352935E+016 -2.29978882342E+016 -2.00913447742E+016 -988956603493 -3553603079600 -62958418004000 -59400524191400 -83407450316900 -65572677829700 -84364531918100 -72480150655100 -91424775022100 -204977960789000 -112276529053000 -270065974142000 -208000523684000 -226507716826000 -278686789834000 -203510820353000 -224510263726000 -186154630320000 -239667454588000 -408940190264000 -447587807344000 -412428554779000 -395727033684000 -371527732444000 -468010465514000 -553990494377000 -535098907444000 -654773728324000 -978214755119000 -797892944175000 -895482127406000 -1195840287340000 -723687815191000 -1532191746940000 -1915578681090000 -1594102374250000 -1493104126630000 -736986471019000 -1519998138570000 -2414228080600000 -1435918033030000 -1561546945390000 --0.429559544383,-0.141336559823,-0.324322498044,-0.364165844582 --0.429559544383,-0.141336559823,-0.324322498044,-0.319791577637 --0.429559544383,-0.141336559823,-0.324322498044,-0.275417310691 --0.429559544383,-0.141336559823,-0.324322498044,-0.1866687768 --0.429559544383,-0.141336559823,-0.324322498044,-0.142294509854 --0.429559544383,-0.141336559823,-0.324322498044,-0.0979202429087 --0.429559544383,-0.141336559823,-0.324322498044,-0.0535459759631 --0.429559544383,-0.141336559823,-0.324322498044,0.0352025579281 --0.429559544383,-0.141336559823,-0.324322498044,0.0795768248736 --0.429559544383,-0.141336559823,-0.324322498044,0.123951091819 --0.429559544383,-0.141336559823,-0.324322498044,0.21269962571 --0.429559544383,-0.141336559823,-0.324322498044,0.257073892656 --0.429559544383,-0.141336559823,-0.324322498044,0.301448159602 --0.429559544383,-0.141336559823,-0.324322498044,0.345822426547 --0.429559544383,-0.141336559823,-0.32118845668,-0.452914378473 --0.429559544383,-0.141336559823,-0.32118845668,-0.364165844582 --0.429559544383,-0.141336559823,-0.32118845668,-0.319791577637 --0.429559544383,-0.141336559823,-0.32118845668,-0.275417310691 --0.429559544383,-0.141336559823,-0.32118845668,-0.1866687768 --0.429559544383,-0.141336559823,-0.32118845668,-0.142294509854 --0.429559544383,-0.141336559823,-0.32118845668,-0.0979202429087 --0.429559544383,-0.141336559823,-0.32118845668,-0.0535459759631 --0.429559544383,-0.141336559823,-0.32118845668,0.0352025579281 --0.429559544383,-0.141336559823,-0.32118845668,0.0795768248736 --0.429559544383,-0.141336559823,-0.32118845668,0.123951091819 --0.429559544383,-0.141336559823,-0.32118845668,0.21269962571 --0.429559544383,-0.141336559823,-0.32118845668,0.257073892656 --0.429559544383,-0.141336559823,-0.32118845668,0.301448159602 --0.429559544383,-0.141336559823,-0.32118845668,0.345822426547 --0.429559544383,-0.141336559823,-0.32118845668,0.346266169217 --0.429559544383,-0.141336559823,-0.314920373953,-0.452914378473 --0.429559544383,-0.141336559823,-0.314920373953,-0.364165844582 --0.429559544383,-0.141336559823,-0.314920373953,-0.319791577637 --0.429559544383,-0.141336559823,-0.314920373953,-0.275417310691 --0.429559544383,-0.141336559823,-0.314920373953,-0.1866687768 --0.429559544383,-0.141336559823,-0.314920373953,-0.142294509854 --0.429559544383,-0.141336559823,-0.314920373953,-0.0979202429087 --0.429559544383,-0.141336559823,-0.314920373953,-0.0535459759631 --0.429559544383,-0.141336559823,-0.314920373953,0.0352025579281 --0.429559544383,-0.141336559823,-0.314920373953,0.0795768248736 --0.429559544383,-0.141336559823,-0.314920373953,0.123951091819 --0.429559544383,-0.141336559823,-0.314920373953,0.21269962571 --0.429559544383,-0.141336559823,-0.314920373953,0.257073892656 --0.429559544383,-0.141336559823,-0.314920373953,0.301448159602 --0.429559544383,-0.141336559823,-0.314920373953,0.345822426547 --0.429559544383,-0.141336559823,-0.314920373953,0.346266169217 --0.429559544383,-0.141336559823,-0.302384208499,-0.364165844582 --0.429559544383,-0.141336559823,-0.302384208499,-0.319791577637 --0.429559544383,-0.141336559823,-0.302384208499,-0.275417310691 --0.429559544383,-0.141336559823,-0.302384208499,-0.1866687768 --0.429559544383,-0.141336559823,-0.302384208499,-0.142294509854 --0.429559544383,-0.141336559823,-0.302384208499,-0.0979202429087 --0.429559544383,-0.141336559823,-0.302384208499,-0.0535459759631 --0.429559544383,-0.141336559823,-0.302384208499,0.0352025579281 --0.429559544383,-0.141336559823,-0.302384208499,0.0795768248736 --0.429559544383,-0.141336559823,-0.302384208499,0.123951091819 --0.429559544383,-0.141336559823,-0.302384208499,0.257073892656 --0.429559544383,-0.141336559823,-0.302384208499,0.301448159602 --0.429559544383,-0.141336559823,-0.302384208499,0.345822426547 --0.429559544383,-0.141336559823,-0.302384208499,0.346266169217 --0.429559544383,-0.141336559823,-0.277311877591,-0.319791577637 --0.429559544383,-0.141336559823,-0.277311877591,-0.1866687768 --0.429559544383,-0.141336559823,-0.277311877591,-0.142294509854 --0.429559544383,-0.141336559823,-0.277311877591,-0.0979202429087 --0.429559544383,-0.141336559823,-0.277311877591,-0.0535459759631 --0.429559544383,-0.141336559823,-0.277311877591,0.0352025579281 --0.429559544383,-0.141336559823,-0.277311877591,0.257073892656 --0.429559544383,-0.141336559823,-0.277311877591,0.301448159602 --0.429559544383,-0.141336559823,-0.227167215775,-0.452914378473 --0.429559544383,-0.141336559823,-0.227167215775,-0.364165844582 --0.429559544383,-0.141336559823,-0.227167215775,-0.319791577637 --0.429559544383,-0.141336559823,-0.227167215775,-0.275417310691 --0.429559544383,-0.141336559823,-0.126877892144,-0.452914378473 --0.269723434845,-0.141336559823,-0.324322498044,-0.452914378473 --0.269723434845,-0.141336559823,-0.324322498044,-0.364165844582 --0.269723434845,-0.141336559823,-0.324322498044,-0.319791577637 --0.269723434845,-0.141336559823,-0.324322498044,-0.275417310691 --0.269723434845,-0.141336559823,-0.324322498044,-0.1866687768 --0.269723434845,-0.141336559823,-0.324322498044,-0.142294509854 --0.269723434845,-0.141336559823,-0.324322498044,-0.0979202429087 --0.269723434845,-0.141336559823,-0.324322498044,-0.0535459759631 --0.269723434845,-0.141336559823,-0.324322498044,0.0352025579281 --0.269723434845,-0.141336559823,-0.324322498044,0.0795768248736 --0.269723434845,-0.141336559823,-0.324322498044,0.123951091819 --0.269723434845,-0.141336559823,-0.324322498044,0.21269962571 --0.269723434845,-0.141336559823,-0.324322498044,0.257073892656 --0.269723434845,-0.141336559823,-0.324322498044,0.301448159602 --0.269723434845,-0.141336559823,-0.324322498044,0.345822426547 --0.269723434845,-0.141336559823,-0.324322498044,0.346266169217 --0.269723434845,-0.141336559823,-0.32118845668,-0.452914378473 --0.269723434845,-0.141336559823,-0.32118845668,-0.364165844582 --0.269723434845,-0.141336559823,-0.32118845668,-0.319791577637 --0.269723434845,-0.141336559823,-0.32118845668,-0.275417310691 --0.269723434845,-0.141336559823,-0.32118845668,-0.1866687768 --0.269723434845,-0.141336559823,-0.32118845668,-0.142294509854 --0.269723434845,-0.141336559823,-0.32118845668,-0.0979202429087 --0.269723434845,-0.141336559823,-0.32118845668,-0.0535459759631 --0.269723434845,-0.141336559823,-0.32118845668,0.0352025579281 --0.269723434845,-0.141336559823,-0.32118845668,0.0795768248736 --0.269723434845,-0.141336559823,-0.32118845668,0.123951091819 --0.269723434845,-0.141336559823,-0.32118845668,0.257073892656 --0.269723434845,-0.141336559823,-0.32118845668,0.301448159602 --0.269723434845,-0.141336559823,-0.32118845668,0.345822426547 --0.269723434845,-0.141336559823,-0.32118845668,0.346266169217 --0.269723434845,-0.141336559823,-0.314920373953,-0.452914378473 --0.269723434845,-0.141336559823,-0.314920373953,-0.364165844582 --0.269723434845,-0.141336559823,-0.314920373953,-0.319791577637 --0.269723434845,-0.141336559823,-0.314920373953,-0.275417310691 --0.269723434845,-0.141336559823,-0.314920373953,-0.1866687768 --0.269723434845,-0.141336559823,-0.314920373953,-0.142294509854 --0.269723434845,-0.141336559823,-0.314920373953,-0.0979202429087 --0.269723434845,-0.141336559823,-0.314920373953,-0.0535459759631 --0.269723434845,-0.141336559823,-0.314920373953,0.123951091819 --0.269723434845,-0.141336559823,-0.314920373953,0.21269962571 --0.269723434845,-0.141336559823,-0.314920373953,0.257073892656 --0.269723434845,-0.141336559823,-0.314920373953,0.345822426547 --0.269723434845,-0.141336559823,-0.314920373953,0.346266169217 --0.269723434845,-0.141336559823,-0.302384208499,-0.452914378473 --0.269723434845,-0.141336559823,-0.302384208499,-0.319791577637 --0.269723434845,-0.141336559823,-0.302384208499,-0.142294509854 --0.269723434845,-0.141336559823,-0.302384208499,-0.0535459759631 --0.269723434845,-0.141336559823,-0.302384208499,0.0352025579281 --0.269723434845,-0.141336559823,-0.302384208499,0.123951091819 --0.269723434845,-0.141336559823,-0.302384208499,0.21269962571 --0.269723434845,-0.141336559823,-0.302384208499,0.257073892656 --0.269723434845,-0.141336559823,-0.302384208499,0.345822426547 --0.269723434845,-0.141336559823,-0.302384208499,0.346266169217 --0.269723434845,-0.141336559823,-0.277311877591,-0.364165844582 --0.269723434845,-0.141336559823,-0.277311877591,-0.319791577637 --0.269723434845,-0.141336559823,-0.277311877591,-0.1866687768 --0.269723434845,-0.141336559823,-0.277311877591,-0.0535459759631 --0.269723434845,-0.141336559823,-0.277311877591,0.301448159602 --0.269723434845,-0.141336559823,-0.227167215775,-0.1866687768 --0.269723434845,-0.141336559823,-0.227167215775,-0.142294509854 --0.269723434845,0.018499549715,-0.324322498044,-0.364165844582 --0.269723434845,0.018499549715,-0.324322498044,-0.319791577637 --0.269723434845,0.018499549715,-0.324322498044,-0.275417310691 --0.269723434845,0.018499549715,-0.324322498044,-0.1866687768 --0.269723434845,0.018499549715,-0.324322498044,-0.142294509854 --0.269723434845,0.018499549715,-0.324322498044,-0.0979202429087 --0.269723434845,0.018499549715,-0.324322498044,-0.0535459759631 --0.269723434845,0.018499549715,-0.324322498044,0.0352025579281 --0.269723434845,0.018499549715,-0.324322498044,0.0795768248736 --0.269723434845,0.018499549715,-0.324322498044,0.123951091819 --0.269723434845,0.018499549715,-0.324322498044,0.21269962571 --0.269723434845,0.018499549715,-0.324322498044,0.257073892656 --0.269723434845,0.018499549715,-0.324322498044,0.301448159602 --0.269723434845,0.018499549715,-0.324322498044,0.345822426547 --0.269723434845,0.018499549715,-0.324322498044,0.346266169217 --0.269723434845,0.018499549715,-0.32118845668,-0.452914378473 --0.269723434845,0.018499549715,-0.32118845668,-0.364165844582 --0.269723434845,0.018499549715,-0.32118845668,-0.319791577637 --0.269723434845,0.018499549715,-0.32118845668,-0.275417310691 --0.269723434845,0.018499549715,-0.32118845668,-0.1866687768 --0.269723434845,0.018499549715,-0.32118845668,-0.142294509854 --0.269723434845,0.018499549715,-0.32118845668,-0.0979202429087 --0.269723434845,0.018499549715,-0.32118845668,-0.0535459759631 --0.269723434845,0.018499549715,-0.32118845668,0.0352025579281 --0.269723434845,0.018499549715,-0.32118845668,0.0795768248736 --0.269723434845,0.018499549715,-0.32118845668,0.123951091819 --0.269723434845,0.018499549715,-0.32118845668,0.21269962571 --0.269723434845,0.018499549715,-0.32118845668,0.257073892656 --0.269723434845,0.018499549715,-0.32118845668,0.301448159602 --0.269723434845,0.018499549715,-0.32118845668,0.345822426547 --0.269723434845,0.018499549715,-0.32118845668,0.346266169217 --0.269723434845,0.018499549715,-0.314920373953,-0.452914378473 --0.269723434845,0.018499549715,-0.314920373953,-0.364165844582 --0.269723434845,0.018499549715,-0.314920373953,-0.319791577637 --0.269723434845,0.018499549715,-0.314920373953,-0.275417310691 --0.269723434845,0.018499549715,-0.314920373953,-0.1866687768 --0.269723434845,0.018499549715,-0.314920373953,-0.142294509854 --0.269723434845,0.018499549715,-0.314920373953,-0.0979202429087 --0.269723434845,0.018499549715,-0.314920373953,-0.0535459759631 --0.269723434845,0.018499549715,-0.314920373953,0.0352025579281 --0.269723434845,0.018499549715,-0.314920373953,0.123951091819 --0.269723434845,0.018499549715,-0.314920373953,0.21269962571 --0.269723434845,0.018499549715,-0.314920373953,0.257073892656 --0.269723434845,0.018499549715,-0.314920373953,0.345822426547 --0.269723434845,0.018499549715,-0.302384208499,-0.364165844582 --0.269723434845,0.018499549715,-0.302384208499,-0.319791577637 --0.269723434845,0.018499549715,-0.302384208499,-0.275417310691 --0.269723434845,0.018499549715,-0.302384208499,-0.1866687768 --0.269723434845,0.018499549715,-0.302384208499,-0.142294509854 --0.269723434845,0.018499549715,-0.302384208499,-0.0979202429087 --0.269723434845,0.018499549715,-0.302384208499,-0.0535459759631 --0.269723434845,0.018499549715,-0.302384208499,0.0352025579281 --0.269723434845,0.018499549715,-0.302384208499,0.123951091819 --0.269723434845,0.018499549715,-0.302384208499,0.257073892656 --0.269723434845,0.018499549715,-0.302384208499,0.301448159602 --0.269723434845,0.018499549715,-0.302384208499,0.346266169217 --0.269723434845,0.018499549715,-0.277311877591,-0.319791577637 --0.269723434845,0.018499549715,-0.277311877591,-0.1866687768 --0.269723434845,0.018499549715,-0.277311877591,-0.142294509854 --0.269723434845,0.018499549715,-0.277311877591,-0.0535459759631 --0.269723434845,0.018499549715,-0.277311877591,0.0352025579281 --0.269723434845,0.018499549715,-0.277311877591,0.257073892656 --0.269723434845,0.018499549715,-0.277311877591,0.346266169217 --0.269723434845,0.018499549715,-0.227167215775,0.123951091819 --0.269723434845,0.018499549715,-0.227167215775,0.21269962571 --0.269723434845,0.018499549715,0.0737007551197,-0.364165844582 -0.369621003307,-0.141336559823,-0.324322498044,-0.364165844582 -0.369621003307,-0.141336559823,-0.324322498044,-0.319791577637 -0.369621003307,-0.141336559823,-0.324322498044,-0.275417310691 -0.369621003307,-0.141336559823,-0.324322498044,-0.1866687768 -0.369621003307,-0.141336559823,-0.324322498044,-0.142294509854 -0.369621003307,-0.141336559823,-0.324322498044,-0.0979202429087 -0.369621003307,-0.141336559823,-0.324322498044,-0.0535459759631 -0.369621003307,-0.141336559823,-0.324322498044,0.0352025579281 -0.369621003307,-0.141336559823,-0.324322498044,0.0795768248736 -0.369621003307,-0.141336559823,-0.324322498044,0.123951091819 -0.369621003307,-0.141336559823,-0.324322498044,0.21269962571 -0.369621003307,-0.141336559823,-0.324322498044,0.257073892656 -0.369621003307,-0.141336559823,-0.324322498044,0.301448159602 -0.369621003307,-0.141336559823,-0.324322498044,0.345822426547 -0.369621003307,-0.141336559823,-0.32118845668,-0.452914378473 -0.369621003307,-0.141336559823,-0.32118845668,-0.364165844582 -0.369621003307,-0.141336559823,-0.32118845668,-0.319791577637 -0.369621003307,-0.141336559823,-0.32118845668,-0.275417310691 -0.369621003307,-0.141336559823,-0.32118845668,-0.1866687768 -0.369621003307,-0.141336559823,-0.32118845668,-0.142294509854 -0.369621003307,-0.141336559823,-0.32118845668,-0.0979202429087 -0.369621003307,-0.141336559823,-0.32118845668,-0.0535459759631 -0.369621003307,-0.141336559823,-0.32118845668,0.0352025579281 -0.369621003307,-0.141336559823,-0.32118845668,0.0795768248736 -0.369621003307,-0.141336559823,-0.32118845668,0.123951091819 -0.369621003307,-0.141336559823,-0.32118845668,0.21269962571 -0.369621003307,-0.141336559823,-0.32118845668,0.257073892656 -0.369621003307,-0.141336559823,-0.32118845668,0.301448159602 -0.369621003307,-0.141336559823,-0.32118845668,0.345822426547 -0.369621003307,-0.141336559823,-0.32118845668,0.346266169217 -0.369621003307,-0.141336559823,-0.314920373953,-0.452914378473 -0.369621003307,-0.141336559823,-0.314920373953,-0.364165844582 -0.369621003307,-0.141336559823,-0.314920373953,-0.319791577637 -0.369621003307,-0.141336559823,-0.314920373953,-0.275417310691 -0.369621003307,-0.141336559823,-0.314920373953,-0.1866687768 -0.369621003307,-0.141336559823,-0.314920373953,-0.142294509854 -0.369621003307,-0.141336559823,-0.314920373953,-0.0979202429087 -0.369621003307,-0.141336559823,-0.314920373953,-0.0535459759631 -0.369621003307,-0.141336559823,-0.314920373953,0.0352025579281 -0.369621003307,-0.141336559823,-0.314920373953,0.0795768248736 -0.369621003307,-0.141336559823,-0.314920373953,0.123951091819 -0.369621003307,-0.141336559823,-0.314920373953,0.21269962571 -0.369621003307,-0.141336559823,-0.314920373953,0.301448159602 -0.369621003307,-0.141336559823,-0.314920373953,0.345822426547 -0.369621003307,-0.141336559823,-0.314920373953,0.346266169217 -0.369621003307,-0.141336559823,-0.302384208499,-0.452914378473 -0.369621003307,-0.141336559823,-0.302384208499,-0.364165844582 -0.369621003307,-0.141336559823,-0.302384208499,-0.319791577637 -0.369621003307,-0.141336559823,-0.302384208499,-0.275417310691 -0.369621003307,-0.141336559823,-0.302384208499,-0.142294509854 -0.369621003307,-0.141336559823,-0.302384208499,-0.0979202429087 -0.369621003307,-0.141336559823,-0.302384208499,-0.0535459759631 -0.369621003307,-0.141336559823,-0.302384208499,0.123951091819 -0.369621003307,-0.141336559823,-0.302384208499,0.257073892656 -0.369621003307,-0.141336559823,-0.302384208499,0.301448159602 -0.369621003307,-0.141336559823,-0.302384208499,0.346266169217 -0.369621003307,-0.141336559823,-0.277311877591,-0.364165844582 -0.369621003307,-0.141336559823,-0.277311877591,-0.319791577637 -0.369621003307,-0.141336559823,-0.277311877591,-0.275417310691 -0.369621003307,-0.141336559823,-0.277311877591,0.0795768248736 -0.369621003307,-0.141336559823,-0.277311877591,0.346266169217 -0.369621003307,-0.141336559823,-0.227167215775,-0.142294509854 -0.369621003307,-0.141336559823,-0.227167215775,0.301448159602 -0.369621003307,-0.141336559823,-0.126877892144,0.0352025579281 -0.369621003307,0.018499549715,-0.324322498044,-0.452914378473 -0.369621003307,0.018499549715,-0.324322498044,-0.364165844582 -0.369621003307,0.018499549715,-0.324322498044,-0.319791577637 -0.369621003307,0.018499549715,-0.324322498044,-0.275417310691 -0.369621003307,0.018499549715,-0.324322498044,-0.1866687768 -0.369621003307,0.018499549715,-0.324322498044,-0.142294509854 -0.369621003307,0.018499549715,-0.324322498044,-0.0979202429087 -0.369621003307,0.018499549715,-0.324322498044,-0.0535459759631 -0.369621003307,0.018499549715,-0.324322498044,0.0352025579281 -0.369621003307,0.018499549715,-0.324322498044,0.0795768248736 -0.369621003307,0.018499549715,-0.324322498044,0.123951091819 -0.369621003307,0.018499549715,-0.324322498044,0.21269962571 -0.369621003307,0.018499549715,-0.324322498044,0.257073892656 -0.369621003307,0.018499549715,-0.324322498044,0.301448159602 -0.369621003307,0.018499549715,-0.324322498044,0.345822426547 -0.369621003307,0.018499549715,-0.324322498044,0.346266169217 -0.369621003307,0.018499549715,-0.32118845668,-0.364165844582 -0.369621003307,0.018499549715,-0.32118845668,-0.319791577637 -0.369621003307,0.018499549715,-0.32118845668,-0.275417310691 -0.369621003307,0.018499549715,-0.32118845668,-0.142294509854 -0.369621003307,0.018499549715,-0.32118845668,-0.0979202429087 -0.369621003307,0.018499549715,-0.32118845668,-0.0535459759631 -0.369621003307,0.018499549715,-0.32118845668,0.0352025579281 -0.369621003307,0.018499549715,-0.32118845668,0.0795768248736 -0.369621003307,0.018499549715,-0.32118845668,0.123951091819 -0.369621003307,0.018499549715,-0.32118845668,0.21269962571 -0.369621003307,0.018499549715,-0.32118845668,0.257073892656 -0.369621003307,0.018499549715,-0.32118845668,0.301448159602 -0.369621003307,0.018499549715,-0.32118845668,0.345822426547 -0.369621003307,0.018499549715,-0.32118845668,0.346266169217 -0.369621003307,0.018499549715,-0.314920373953,-0.452914378473 -0.369621003307,0.018499549715,-0.314920373953,-0.364165844582 -0.369621003307,0.018499549715,-0.314920373953,-0.319791577637 -0.369621003307,0.018499549715,-0.314920373953,-0.275417310691 -0.369621003307,0.018499549715,-0.314920373953,-0.1866687768 -0.369621003307,0.018499549715,-0.314920373953,-0.142294509854 -0.369621003307,0.018499549715,-0.314920373953,-0.0979202429087 -0.369621003307,0.018499549715,-0.314920373953,-0.0535459759631 -0.369621003307,0.018499549715,-0.314920373953,0.0352025579281 -0.369621003307,0.018499549715,-0.314920373953,0.123951091819 -0.369621003307,0.018499549715,-0.314920373953,0.21269962571 -0.369621003307,0.018499549715,-0.314920373953,0.257073892656 -0.369621003307,0.018499549715,-0.314920373953,0.301448159602 -0.369621003307,0.018499549715,-0.314920373953,0.345822426547 -0.369621003307,0.018499549715,-0.314920373953,0.346266169217 -0.369621003307,0.018499549715,-0.302384208499,-0.452914378473 -0.369621003307,0.018499549715,-0.302384208499,-0.364165844582 -0.369621003307,0.018499549715,-0.302384208499,-0.319791577637 -0.369621003307,0.018499549715,-0.302384208499,-0.275417310691 -0.369621003307,0.018499549715,-0.302384208499,-0.1866687768 -0.369621003307,0.018499549715,-0.302384208499,-0.142294509854 -0.369621003307,0.018499549715,-0.302384208499,-0.0979202429087 -0.369621003307,0.018499549715,-0.302384208499,0.0352025579281 -0.369621003307,0.018499549715,-0.302384208499,0.123951091819 -0.369621003307,0.018499549715,-0.302384208499,0.21269962571 -0.369621003307,0.018499549715,-0.302384208499,0.257073892656 -0.369621003307,0.018499549715,-0.302384208499,0.301448159602 -0.369621003307,0.018499549715,-0.302384208499,0.345822426547 -0.369621003307,0.018499549715,-0.302384208499,0.346266169217 -0.369621003307,0.018499549715,-0.277311877591,-0.364165844582 -0.369621003307,0.018499549715,-0.277311877591,-0.319791577637 -0.369621003307,0.018499549715,-0.277311877591,-0.275417310691 -0.369621003307,0.018499549715,-0.277311877591,-0.0535459759631 -0.369621003307,0.018499549715,-0.277311877591,0.0352025579281 -0.369621003307,0.018499549715,-0.277311877591,0.21269962571 -0.369621003307,0.018499549715,-0.277311877591,0.257073892656 -0.369621003307,0.018499549715,-0.277311877591,0.345822426547 -0.369621003307,0.018499549715,-0.277311877591,0.346266169217 -0.369621003307,0.018499549715,-0.227167215775,-0.0535459759631 -0.369621003307,0.018499549715,-0.227167215775,0.21269962571 -0.369621003307,0.657843987867,-0.324322498044,-0.364165844582 -0.369621003307,0.657843987867,-0.324322498044,-0.319791577637 -0.369621003307,0.657843987867,-0.324322498044,-0.275417310691 -0.369621003307,0.657843987867,-0.324322498044,-0.1866687768 -0.369621003307,0.657843987867,-0.324322498044,-0.142294509854 -0.369621003307,0.657843987867,-0.324322498044,-0.0979202429087 -0.369621003307,0.657843987867,-0.324322498044,-0.0535459759631 -0.369621003307,0.657843987867,-0.324322498044,0.0352025579281 -0.369621003307,0.657843987867,-0.324322498044,0.0795768248736 -0.369621003307,0.657843987867,-0.324322498044,0.123951091819 -0.369621003307,0.657843987867,-0.324322498044,0.21269962571 -0.369621003307,0.657843987867,-0.324322498044,0.257073892656 -0.369621003307,0.657843987867,-0.324322498044,0.301448159602 -0.369621003307,0.657843987867,-0.324322498044,0.345822426547 -0.369621003307,0.657843987867,-0.32118845668,-0.452914378473 -0.369621003307,0.657843987867,-0.32118845668,-0.364165844582 -0.369621003307,0.657843987867,-0.32118845668,-0.319791577637 -0.369621003307,0.657843987867,-0.32118845668,-0.275417310691 -0.369621003307,0.657843987867,-0.32118845668,-0.1866687768 -0.369621003307,0.657843987867,-0.32118845668,-0.142294509854 -0.369621003307,0.657843987867,-0.32118845668,-0.0979202429087 -0.369621003307,0.657843987867,-0.32118845668,-0.0535459759631 -0.369621003307,0.657843987867,-0.32118845668,0.0352025579281 -0.369621003307,0.657843987867,-0.32118845668,0.0795768248736 -0.369621003307,0.657843987867,-0.32118845668,0.123951091819 -0.369621003307,0.657843987867,-0.32118845668,0.21269962571 -0.369621003307,0.657843987867,-0.32118845668,0.257073892656 -0.369621003307,0.657843987867,-0.32118845668,0.301448159602 -0.369621003307,0.657843987867,-0.32118845668,0.345822426547 -0.369621003307,0.657843987867,-0.32118845668,0.346266169217 -0.369621003307,0.657843987867,-0.314920373953,-0.452914378473 -0.369621003307,0.657843987867,-0.314920373953,-0.364165844582 -0.369621003307,0.657843987867,-0.314920373953,-0.319791577637 -0.369621003307,0.657843987867,-0.314920373953,-0.275417310691 -0.369621003307,0.657843987867,-0.314920373953,-0.1866687768 -0.369621003307,0.657843987867,-0.314920373953,-0.0979202429087 -0.369621003307,0.657843987867,-0.314920373953,-0.0535459759631 -0.369621003307,0.657843987867,-0.314920373953,0.0352025579281 -0.369621003307,0.657843987867,-0.314920373953,0.0795768248736 -0.369621003307,0.657843987867,-0.314920373953,0.123951091819 -0.369621003307,0.657843987867,-0.314920373953,0.21269962571 -0.369621003307,0.657843987867,-0.314920373953,0.257073892656 -0.369621003307,0.657843987867,-0.314920373953,0.301448159602 -0.369621003307,0.657843987867,-0.314920373953,0.345822426547 -0.369621003307,0.657843987867,-0.314920373953,0.346266169217 -0.369621003307,0.657843987867,-0.302384208499,-0.452914378473 -0.369621003307,0.657843987867,-0.302384208499,-0.364165844582 -0.369621003307,0.657843987867,-0.302384208499,-0.319791577637 -0.369621003307,0.657843987867,-0.302384208499,-0.1866687768 -0.369621003307,0.657843987867,-0.302384208499,-0.142294509854 -0.369621003307,0.657843987867,-0.302384208499,-0.0979202429087 -0.369621003307,0.657843987867,-0.302384208499,-0.0535459759631 -0.369621003307,0.657843987867,-0.302384208499,0.0352025579281 -0.369621003307,0.657843987867,-0.302384208499,0.0795768248736 -0.369621003307,0.657843987867,-0.302384208499,0.123951091819 -0.369621003307,0.657843987867,-0.302384208499,0.21269962571 -0.369621003307,0.657843987867,-0.302384208499,0.257073892656 -0.369621003307,0.657843987867,-0.302384208499,0.301448159602 -0.369621003307,0.657843987867,-0.302384208499,0.345822426547 -0.369621003307,0.657843987867,-0.302384208499,0.346266169217 -0.369621003307,0.657843987867,-0.277311877591,-0.452914378473 -0.369621003307,0.657843987867,-0.277311877591,-0.364165844582 -0.369621003307,0.657843987867,-0.277311877591,-0.319791577637 -0.369621003307,0.657843987867,-0.277311877591,-0.275417310691 -0.369621003307,0.657843987867,-0.277311877591,-0.1866687768 -0.369621003307,0.657843987867,-0.277311877591,-0.142294509854 -0.369621003307,0.657843987867,-0.277311877591,-0.0979202429087 -0.369621003307,0.657843987867,-0.277311877591,-0.0535459759631 -0.369621003307,0.657843987867,-0.277311877591,0.0352025579281 -0.369621003307,0.657843987867,-0.277311877591,0.0795768248736 -0.369621003307,0.657843987867,-0.277311877591,0.123951091819 -0.369621003307,0.657843987867,-0.277311877591,0.21269962571 -0.369621003307,0.657843987867,-0.277311877591,0.257073892656 -0.369621003307,0.657843987867,-0.277311877591,0.301448159602 -0.369621003307,0.657843987867,-0.277311877591,0.345822426547 -0.369621003307,0.657843987867,-0.277311877591,0.346266169217 -0.369621003307,0.657843987867,-0.227167215775,-0.452914378473 -0.369621003307,0.657843987867,-0.227167215775,-0.364165844582 -0.369621003307,0.657843987867,-0.227167215775,-0.319791577637 -0.369621003307,0.657843987867,-0.227167215775,-0.275417310691 -0.369621003307,0.657843987867,-0.227167215775,-0.1866687768 -0.369621003307,0.657843987867,-0.227167215775,-0.142294509854 -0.369621003307,0.657843987867,-0.227167215775,-0.0979202429087 -0.369621003307,0.657843987867,-0.227167215775,-0.0535459759631 -0.369621003307,0.657843987867,-0.227167215775,0.123951091819 -0.369621003307,0.657843987867,-0.227167215775,0.301448159602 -0.369621003307,0.657843987867,-0.227167215775,0.346266169217 -0.369621003307,0.657843987867,-0.126877892144,-0.452914378473 -0.369621003307,0.657843987867,-0.126877892144,-0.364165844582 -0.369621003307,0.657843987867,-0.126877892144,-0.319791577637 -0.369621003307,0.657843987867,-0.126877892144,-0.275417310691 -0.369621003307,0.657843987867,-0.126877892144,-0.142294509854 -0.369621003307,0.657843987867,-0.126877892144,-0.0535459759631 -0.369621003307,0.657843987867,-0.126877892144,0.0352025579281 -0.369621003307,0.657843987867,-0.126877892144,0.345822426547 -0.369621003307,0.657843987867,0.0737007551197,-0.452914378473 -0.369621003307,0.657843987867,0.0737007551197,-0.1866687768 -0.369621003307,0.657843987867,0.0737007551197,0.345822426547 diff --git a/toms1012/samplep.f90 b/toms1012/samplep.f90 deleted file mode 100644 index f253260..0000000 --- a/toms1012/samplep.f90 +++ /dev/null @@ -1,155 +0,0 @@ -PROGRAM SAMPLE_MAIN_P -! Driver code that reads a set P of data points from a file and computes -! the containing simplices and interpolation weights for a set Q of -! user-specified interpolation points using DELAUNAYSPARSEP. If response -! values are provided, the interpolant f_{DT}(q) is also computed for all -! q \in Q. -! -! Usage: ./samplep $(filepath) -! -! where $(filepath) is the relative or absolute path to the input file, -! formatted as follows. -! -! D,N,M,IR -! [Data/training points] -! [Response/function values] -! [Interpolation points] -! -! where -! D is the dimension of problem, -! N is the number of data/training points (contained in lines 2 -- N+1), -! M is the number of interpolation points (contained in lines 2N+2 -- 2N+1+M), -! IR is the dimension of the output f(x) (the corresponding f(p) for p \in P -! are stored in lines N+2 -- 2N+1). -! -! If IR = 0, then no interpolation will be done (and the M interpolation points -! are stored in lines N+2 -- N+1+M). -! -! A sample input file with D=2, N=43, M=101, IR=1 is provided by -! sample_input2d.dat. -! A sample input file with D=4, N=432, M=432, IR=1 is provided by -! sample_input4d.dat. -! -! Last Update: March, 2020 -! Primary Author: Tyler Chang -USE DELSPARSE_MOD -USE OMP_LIB -IMPLICIT NONE - -! Declare arguments and local data. -! Problem dimensions. -INTEGER :: D ! Problem dimension. -INTEGER :: N ! Number of data points. -INTEGER :: M ! Number of interpolation points. -INTEGER :: IR ! Response values (i.e., the dimension of the output). -! DELAUNAYSPARSE argument arrays. -REAL(KIND=R8), ALLOCATABLE :: PTS(:,:) ! The input data points. -REAL(KIND=R8), ALLOCATABLE :: Q(:,:) ! The interpolation points. -REAL(KIND=R8), ALLOCATABLE :: WEIGHTS(:,:) ! The interpolation weights. -INTEGER, ALLOCATABLE :: SIMPS(:,:) ! The indices of the simplex vertices. -INTEGER, ALLOCATABLE :: IERR(:) ! Array of integer error flags. -! Optional argument arrays. -REAL(KIND=R8), ALLOCATABLE :: INTERP_IN(:,:) ! Response value array. -REAL(KIND=R8), ALLOCATABLE :: INTERP_OUT(:,:) ! Output array for f_DT(q). -REAL(KIND=R8), ALLOCATABLE :: RNORM(:) ! Array of extrapolation residuals. -! Local variables. -INTEGER :: I ! Loop index/temp value. -REAL(KIND=R8) :: TICK ! The current clock time/total walltime. -CHARACTER(LEN=80) :: FILEPATH ! Input filepath. - -! Open the file path $(filepath), and get the metadata from the -! first line (D, N, M, and IR). -CALL GET_COMMAND_ARGUMENT(1, FILEPATH) -OPEN(1, FILE=TRIM(FILEPATH)) -READ(1, *) D, N, M, IR -IF(D .LE. 0 .OR. N .LE. 0 .OR. M .LE. 0) THEN - WRITE(*,*) "Illegal input dimensions in input file, line 1."; STOP -END IF - -! Allocate all necessarry arrays. -ALLOCATE(PTS(D,N), WEIGHTS(D+1,M), Q(D,M), SIMPS(D+1,M), IERR(M), & - & RNORM(M), STAT=I) -IF(I .NE. 0) THEN - WRITE(*,*) "Memory allocation error."; STOP -END IF - -! Read the input data/training points into PTS. -DO I = 1, N - READ(1, *) PTS(:, I) -END DO -! Check if there are any response values. -IF (IR > 0) THEN - ! If so, allocate INTERP_IN and INTERP_OUT. - ALLOCATE(INTERP_IN(IR,N), INTERP_OUT(IR,M), STAT=I) - IF(I .NE. 0) THEN - WRITE(*,*) "Memory allocation error."; STOP - END IF - ! Then, read the response values into INTERP_IN. - DO I = 1, N - READ(1, *) INTERP_IN(:,I) - END DO -END IF -! Read the interpolation points into Q. -DO I = 1, M - READ(1, *) Q(:, I) -END DO -CLOSE(1) - -! Compute the interpolation results and time. -! If response values are provided, compute the outputs f_{DT}(q). -IF (IR > 0) THEN - TICK = OMP_GET_WTIME() - ! Call DELAUNAYSPARSEP with INTERP_IN and INTERP_OUT. - CALL DELAUNAYSPARSEP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - ! Optional argument list. - & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT, & - & EPS=SQRT(EPSILON(0.0_R8)), EXTRAP=0.1_R8, RNORM=RNORM, & - & IBUDGET = 50000, CHAIN=.FALSE., EXACT=.TRUE., PMODE=1) - TICK = OMP_GET_WTIME() - TICK -! Otherwise, just compute the simplices and weights. -ELSE - TICK = OMP_GET_WTIME() - ! Call DELAUNAYSPARSEP without INTERP_IN and INTERP_OUT. - CALL DELAUNAYSPARSEP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - ! Optional argument list. Note that INTERP_IN and INTERP_OUT - ! have been excluded. - & EPS=SQRT(EPSILON(0.0_R8)), EXTRAP=0.1_R8, RNORM=RNORM, & - & IBUDGET = 50000, CHAIN=.FALSE., EXACT=.TRUE., PMODE=1) - TICK = OMP_GET_WTIME() - TICK - -END IF - -! Display the results of the interpolation. -DO I = 1, M - IF(IERR(I) .EQ. 0) THEN - WRITE(*,10) 'Interpolation point: ', Q(:,I) - WRITE(*,11) 'Simplex: ', SIMPS(:,I) - WRITE(*,10) 'Weights: ', WEIGHTS(:,I) - IF (IR > 0) THEN - WRITE(*,12) 'f(x) = ', INTERP_OUT(:,I) - END IF - ELSE IF(IERR(I) .EQ. 1) THEN - WRITE(*,10) 'Extrapolation point: ', Q(:,I) - WRITE(*,11) 'Simplex: ', SIMPS(:,I) - WRITE(*,10) 'Weights: ', WEIGHTS(:,I) - IF (IR > 0) THEN - WRITE(*,12) 'f(x) = ', INTERP_OUT(:,I) - END IF - WRITE(*,13) 'Residual: ', RNORM(I) - ELSE IF(IERR(I) .EQ. 2) THEN - WRITE(*,10) 'Extrapolation point: ', Q(:,I) - WRITE(*,13) 'Residual: ', RNORM(I) - ELSE - WRITE(*,14) 'Error at point ', I, '. IERR(I) = ', IERR(I) - END IF -END DO -! Print the timing data. -WRITE(*,15) M, ' points interpolated in ', TICK, ' seconds.' -10 FORMAT(1X,A,/,(1X,5ES15.7)) -11 FORMAT(1X,A,/,(10I7)) -12 FORMAT(1X,A,4ES15.7,/,(1X,5ES15.7)) -13 FORMAT(1X,A,ES16.8) -14 FORMAT(1X,A,I7,A,I2) -15 FORMAT(/,I7,A,ES16.8,A,/) - -END PROGRAM SAMPLE_MAIN_P diff --git a/toms1012/samples.f90 b/toms1012/samples.f90 deleted file mode 100644 index 255bf1f..0000000 --- a/toms1012/samples.f90 +++ /dev/null @@ -1,155 +0,0 @@ -PROGRAM SAMPLE_MAIN_S -! Driver code that reads a set P of data points from a file and computes -! the containing simplices and interpolation weights for a set Q of -! user-specified interpolation points using DELAUNAYSPARSES. If response -! values are provided, the interpolant f_{DT}(q) is also computed for all -! q \in Q. -! -! Usage: ./samples $(filepath) -! -! where $(filepath) is the relative or absolute path to the input file, -! formatted as follows. -! -! D,N,M,IR -! [Data/training points] -! [Response/function values] -! [Interpolation points] -! -! where -! D is the dimension of problem, -! N is the number of data/training points (contained in lines 2 -- N+1), -! M is the number of interpolation points (contained in lines 2N+2 -- 2N+1+M), -! IR is the dimension of the output f(x) (the corresponding f(p) for p \in P -! are stored in lines N+2 -- 2N+1). -! -! If IR = 0, then no interpolation will be done (and the M interpolation points -! are stored in lines N+2 -- N+1+M). -! -! A sample input file with D=2, N=43, M=101, IR=1 is provided by -! sample_input2d.dat. -! A sample input file with D=4, N=432, M=432, IR=1 is provided by -! sample_input4d.dat. -! -! Last Update: March, 2020 -! Primary Author: Tyler Chang -USE DELSPARSE_MOD -USE OMP_LIB -IMPLICIT NONE - -! Declare arguments and local data. -! Problem dimensions. -INTEGER :: D ! Problem dimension. -INTEGER :: N ! Number of data points. -INTEGER :: M ! Number of interpolation points. -INTEGER :: IR ! Response values (i.e., the dimension of the output). -! DELAUNAYSPARSE argument arrays. -REAL(KIND=R8), ALLOCATABLE :: PTS(:,:) ! The input data points. -REAL(KIND=R8), ALLOCATABLE :: Q(:,:) ! The interpolation points. -REAL(KIND=R8), ALLOCATABLE :: WEIGHTS(:,:) ! The interpolation weights. -INTEGER, ALLOCATABLE :: SIMPS(:,:) ! The indices of the simplex vertices. -INTEGER, ALLOCATABLE :: IERR(:) ! Array of integer error flags. -! Optional argument arrays. -REAL(KIND=R8), ALLOCATABLE :: INTERP_IN(:,:) ! Response value array. -REAL(KIND=R8), ALLOCATABLE :: INTERP_OUT(:,:) ! Output array for f_DT(q). -REAL(KIND=R8), ALLOCATABLE :: RNORM(:) ! Array of extrapolation residuals. -! Local variables. -INTEGER :: I ! Loop index/temp value. -REAL(KIND=R8) :: TICK ! The current clock time/total walltime. -CHARACTER(LEN=80) :: FILEPATH ! Input filepath. - -! Open the file path $(filepath), and get the metadata from the -! first line (D, N, M, and IR). -CALL GET_COMMAND_ARGUMENT(1, FILEPATH) -OPEN(1, FILE=TRIM(FILEPATH)) -READ(1, *) D, N, M, IR -IF(D .LE. 0 .OR. N .LE. 0 .OR. M .LE. 0) THEN - WRITE(*,*) "Illegal input dimensions in input file, line 1."; STOP -END IF - -! Allocate all necessarry arrays. -ALLOCATE(PTS(D,N), WEIGHTS(D+1,M), Q(D,M), SIMPS(D+1,M), IERR(M), & - & RNORM(M), STAT=I) -IF(I .NE. 0) THEN - WRITE(*,*) "Memory allocation error."; STOP -END IF - -! Read the input data/training points into PTS. -DO I = 1, N - READ(1, *) PTS(:, I) -END DO -! Check if there are any response values. -IF (IR > 0) THEN - ! If so, allocate INTERP_IN and INTERP_OUT. - ALLOCATE(INTERP_IN(IR,N), INTERP_OUT(IR,M), STAT=I) - IF(I .NE. 0) THEN - WRITE(*,*) "Memory allocation error."; STOP - END IF - ! Then, read the response values into INTERP_IN. - DO I = 1, N - READ(1, *) INTERP_IN(:,I) - END DO -END IF -! Read the interpolation points into Q. -DO I = 1, M - READ(1, *) Q(:, I) -END DO -CLOSE(1) - -! Compute the interpolation results and time. -! If response values are provided, compute the outputs f_{DT}(q). -IF (IR > 0) THEN - TICK = OMP_GET_WTIME() - ! Call DELAUNAYSPARSES with INTERP_IN and INTERP_OUT. - CALL DELAUNAYSPARSES(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - ! Optional argument list. - & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT, & - & EPS=SQRT(EPSILON(0.0_R8)), EXTRAP=0.1_R8, RNORM=RNORM, & - & IBUDGET = 50000, CHAIN=.FALSE., EXACT=.TRUE.) - TICK = OMP_GET_WTIME() - TICK -! Otherwise, just compute the simplices and weights. -ELSE - TICK = OMP_GET_WTIME() - ! Call DELAUNAYSPARSES without INTERP_IN and INTERP_OUT. - CALL DELAUNAYSPARSES(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & - ! Optional argument list. Note that INTERP_IN and INTERP_OUT - ! have been excluded. - & EPS=SQRT(EPSILON(0.0_R8)), EXTRAP=0.1_R8, RNORM=RNORM, & - & IBUDGET = 50000, CHAIN=.FALSE., EXACT=.TRUE.) - TICK = OMP_GET_WTIME() - TICK - -END IF - -! Display the results of the interpolation. -DO I = 1, M - IF(IERR(I) .EQ. 0) THEN - WRITE(*,10) 'Interpolation point: ', Q(:,I) - WRITE(*,11) 'Simplex: ', SIMPS(:,I) - WRITE(*,10) 'Weights: ', WEIGHTS(:,I) - IF (IR > 0) THEN - WRITE(*,12) 'f(x) = ', INTERP_OUT(:,I) - END IF - ELSE IF(IERR(I) .EQ. 1) THEN - WRITE(*,10) 'Extrapolation point: ', Q(:,I) - WRITE(*,11) 'Simplex: ', SIMPS(:,I) - WRITE(*,10) 'Weights: ', WEIGHTS(:,I) - IF (IR > 0) THEN - WRITE(*,12) 'f(x) = ', INTERP_OUT(:,I) - END IF - WRITE(*,13) 'Residual: ', RNORM(I) - ELSE IF(IERR(I) .EQ. 2) THEN - WRITE(*,10) 'Extrapolation point: ', Q(:,I) - WRITE(*,13) 'Residual: ', RNORM(I) - ELSE - WRITE(*,14) 'Error at point ', I, '. IERR(I) = ', IERR(I) - END IF -END DO -! Print the timing data. -WRITE(*,15) M, ' points interpolated in ', TICK, ' seconds.' -10 FORMAT(1X,A,/,(1X,5ES15.7)) -11 FORMAT(1X,A,/,(10I7)) -12 FORMAT(1X,A,4ES15.7,/,(1X,5ES15.7)) -13 FORMAT(1X,A,ES16.8) -14 FORMAT(1X,A,I7,A,I2) -15 FORMAT(/,I7,A,ES16.8,A,/) - -END PROGRAM SAMPLE_MAIN_S diff --git a/toms1012/slatec.f b/toms1012/slatec.f deleted file mode 100644 index 7d51578..0000000 --- a/toms1012/slatec.f +++ /dev/null @@ -1,5037 +0,0 @@ -*DECK DLSEI - SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, - + RNORML, MODE, WS, IP) -C***BEGIN PROLOGUE DLSEI -C***PURPOSE Solve a linearly constrained least squares problem with -C equality and inequality constraints, and optionally compute -C a covariance matrix. -C***LIBRARY SLATEC -C***CATEGORY K1A2A, D9 -C***TYPE REAL(KIND=R8) (LSEI-S, DLSEI-D) -C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, -C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, -C QUADRATIC PROGRAMMING -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Abstract -C -C This subprogram solves a linearly constrained least squares -C problem with both equality and inequality constraints, and, if the -C user requests, obtains a covariance matrix of the solution -C parameters. -C -C Suppose there are given matrices E, A and G of respective -C dimensions ME by N, MA by N and MG by N, and vectors F, B and H of -C respective lengths ME, MA and MG. This subroutine solves the -C linearly constrained least squares problem -C -C EX = F, (E ME by N) (equations to be exactly -C satisfied) -C AX = B, (A MA by N) (equations to be -C approximately satisfied, -C least squares sense) -C GX .GE. H,(G MG by N) (inequality constraints) -C -C The inequalities GX .GE. H mean that every component of the -C product GX must be .GE. the corresponding component of H. -C -C In case the equality constraints cannot be satisfied, a -C generalized inverse solution residual vector length is obtained -C for F-EX. This is the minimal length possible for F-EX. -C -C Any values ME .GE. 0, MA .GE. 0, or MG .GE. 0 are permitted. The -C rank of the matrix E is estimated during the computation. We call -C this value KRANKE. It is an output parameter in IP(1) defined -C below. Using a generalized inverse solution of EX=F, a reduced -C least squares problem with inequality constraints is obtained. -C The tolerances used in these tests for determining the rank -C of E and the rank of the reduced least squares problem are -C given in Sandia Tech. Rept. SAND-78-1290. They can be -C modified by the user if new values are provided in -C the option list of the array PRGOPT(*). -C -C The user must dimension all arrays appearing in the call list.. -C W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2) -C where K=MAX(MA+MG,N). This allows for a solution of a range of -C problems in the given working space. The dimension of WS(*) -C given is a necessary overestimate. Once a particular problem -C has been run, the output parameter IP(3) gives the actual -C dimension required for that problem. -C -C The parameters for DLSEI( ) are -C -C Input.. All TYPE REAL variables are REAL(KIND=R8) -C -C W(*,*),MDW, The array W(*,*) is doubly subscripted with -C ME,MA,MG,N first dimensioning parameter equal to MDW. -C For this discussion let us call M = ME+MA+MG. Then -C MDW must satisfy MDW .GE. M. The condition -C MDW .LT. M is an error. -C -C The array W(*,*) contains the matrices and vectors -C -C (E F) -C (A B) -C (G H) -C -C in rows and columns 1,...,M and 1,...,N+1 -C respectively. -C -C The integers ME, MA, and MG are the -C respective matrix row dimensions -C of E, A and G. Each matrix has N columns. -C -C PRGOPT(*) This real-valued array is the option vector. -C If the user is satisfied with the nominal -C subprogram features set -C -C PRGOPT(1)=1 (or PRGOPT(1)=1.0) -C -C Otherwise PRGOPT(*) is a linked list consisting of -C groups of data of the following form -C -C LINK -C KEY -C DATA SET -C -C The parameters LINK and KEY are each one word. -C The DATA SET can be comprised of several words. -C The number of items depends on the value of KEY. -C The value of LINK points to the first -C entry of the next group of data within -C PRGOPT(*). The exception is when there are -C no more options to change. In that -C case, LINK=1 and the values KEY and DATA SET -C are not referenced. The general layout of -C PRGOPT(*) is as follows. -C -C ...PRGOPT(1) = LINK1 (link to first entry of next group) -C . PRGOPT(2) = KEY1 (key to the option change) -C . PRGOPT(3) = data value (data value for this change) -C . . -C . . -C . . -C ...PRGOPT(LINK1) = LINK2 (link to the first entry of -C . next group) -C . PRGOPT(LINK1+1) = KEY2 (key to the option change) -C . PRGOPT(LINK1+2) = data value -C ... . -C . . -C . . -C ...PRGOPT(LINK) = 1 (no more options to change) -C -C Values of LINK that are nonpositive are errors. -C A value of LINK .GT. NLINK=100000 is also an error. -C This helps prevent using invalid but positive -C values of LINK that will probably extend -C beyond the program limits of PRGOPT(*). -C Unrecognized values of KEY are ignored. The -C order of the options is arbitrary and any number -C of options can be changed with the following -C restriction. To prevent cycling in the -C processing of the option array, a count of the -C number of options changed is maintained. -C Whenever this count exceeds NOPT=1000, an error -C message is printed and the subprogram returns. -C -C Options.. -C -C KEY=1 -C Compute in W(*,*) the N by N -C covariance matrix of the solution variables -C as an output parameter. Nominally the -C covariance matrix will not be computed. -C (This requires no user input.) -C The data set for this option is a single value. -C It must be nonzero when the covariance matrix -C is desired. If it is zero, the covariance -C matrix is not computed. When the covariance matrix -C is computed, the first dimensioning parameter -C of the array W(*,*) must satisfy MDW .GE. MAX(M,N). -C -C KEY=10 -C Suppress scaling of the inverse of the -C normal matrix by the scale factor RNORM**2/ -C MAX(1, no. of degrees of freedom). This option -C only applies when the option for computing the -C covariance matrix (KEY=1) is used. With KEY=1 and -C KEY=10 used as options the unscaled inverse of the -C normal matrix is returned in W(*,*). -C The data set for this option is a single value. -C When it is nonzero no scaling is done. When it is -C zero scaling is done. The nominal case is to do -C scaling so if option (KEY=1) is used alone, the -C matrix will be scaled on output. -C -C KEY=2 -C Scale the nonzero columns of the -C entire data matrix. -C (E) -C (A) -C (G) -C -C to have length one. The data set for this -C option is a single value. It must be -C nonzero if unit length column scaling -C is desired. -C -C KEY=3 -C Scale columns of the entire data matrix -C (E) -C (A) -C (G) -C -C with a user-provided diagonal matrix. -C The data set for this option consists -C of the N diagonal scaling factors, one for -C each matrix column. -C -C KEY=4 -C Change the rank determination tolerance for -C the equality constraint equations from -C the nominal value of SQRT(DRELPR). This quantity can -C be no smaller than DRELPR, the arithmetic- -C storage precision. The quantity DRELPR is the -C largest positive number such that T=1.+DRELPR -C satisfies T .EQ. 1. The quantity used -C here is internally restricted to be at -C least DRELPR. The data set for this option -C is the new tolerance. -C -C KEY=5 -C Change the rank determination tolerance for -C the reduced least squares equations from -C the nominal value of SQRT(DRELPR). This quantity can -C be no smaller than DRELPR, the arithmetic- -C storage precision. The quantity used -C here is internally restricted to be at -C least DRELPR. The data set for this option -C is the new tolerance. -C -C For example, suppose we want to change -C the tolerance for the reduced least squares -C problem, compute the covariance matrix of -C the solution parameters, and provide -C column scaling for the data matrix. For -C these options the dimension of PRGOPT(*) -C must be at least N+9. The Fortran statements -C defining these options would be as follows: -C -C PRGOPT(1)=4 (link to entry 4 in PRGOPT(*)) -C PRGOPT(2)=1 (covariance matrix key) -C PRGOPT(3)=1 (covariance matrix wanted) -C -C PRGOPT(4)=7 (link to entry 7 in PRGOPT(*)) -C PRGOPT(5)=5 (least squares equas. tolerance key) -C PRGOPT(6)=... (new value of the tolerance) -C -C PRGOPT(7)=N+9 (link to entry N+9 in PRGOPT(*)) -C PRGOPT(8)=3 (user-provided column scaling key) -C -C CALL DCOPY (N, D, 1, PRGOPT(9), 1) (Copy the N -C scaling factors from the user array D(*) -C to PRGOPT(9)-PRGOPT(N+8)) -C -C PRGOPT(N+9)=1 (no more options to change) -C -C The contents of PRGOPT(*) are not modified -C by the subprogram. -C The options for WNNLS( ) can also be included -C in this array. The values of KEY recognized -C by WNNLS( ) are 6, 7 and 8. Their functions -C are documented in the usage instructions for -C subroutine WNNLS( ). Normally these options -C do not need to be modified when using DLSEI( ). -C -C IP(1), The amounts of working storage actually -C IP(2) allocated for the working arrays WS(*) and -C IP(*), respectively. These quantities are -C compared with the actual amounts of storage -C needed by DLSEI( ). Insufficient storage -C allocated for either WS(*) or IP(*) is an -C error. This feature was included in DLSEI( ) -C because miscalculating the storage formulas -C for WS(*) and IP(*) might very well lead to -C subtle and hard-to-find execution errors. -C -C The length of WS(*) must be at least -C -C LW = 2*(ME+N)+K+(MG+2)*(N+7) -C -C where K = max(MA+MG,N) -C This test will not be made if IP(1).LE.0. -C -C The length of IP(*) must be at least -C -C LIP = MG+2*N+2 -C This test will not be made if IP(2).LE.0. -C -C Output.. All TYPE REAL variables are REAL(KIND=R8) -C -C X(*),RNORME, The array X(*) contains the solution parameters -C RNORML if the integer output flag MODE = 0 or 1. -C The definition of MODE is given directly below. -C When MODE = 0 or 1, RNORME and RNORML -C respectively contain the residual vector -C Euclidean lengths of F - EX and B - AX. When -C MODE=1 the equality constraint equations EX=F -C are contradictory, so RNORME .NE. 0. The residual -C vector F-EX has minimal Euclidean length. For -C MODE .GE. 2, none of these parameters is defined. -C -C MODE Integer flag that indicates the subprogram -C status after completion. If MODE .GE. 2, no -C solution has been computed. -C -C MODE = -C -C 0 Both equality and inequality constraints -C are compatible and have been satisfied. -C -C 1 Equality constraints are contradictory. -C A generalized inverse solution of EX=F was used -C to minimize the residual vector length F-EX. -C In this sense, the solution is still meaningful. -C -C 2 Inequality constraints are contradictory. -C -C 3 Both equality and inequality constraints -C are contradictory. -C -C The following interpretation of -C MODE=1,2 or 3 must be made. The -C sets consisting of all solutions -C of the equality constraints EX=F -C and all vectors satisfying GX .GE. H -C have no points in common. (In -C particular this does not say that -C each individual set has no points -C at all, although this could be the -C case.) -C -C 4 Usage error occurred. The value -C of MDW is .LT. ME+MA+MG, MDW is -C .LT. N and a covariance matrix is -C requested, or the option vector -C PRGOPT(*) is not properly defined, -C or the lengths of the working arrays -C WS(*) and IP(*), when specified in -C IP(1) and IP(2) respectively, are not -C long enough. -C -C W(*,*) The array W(*,*) contains the N by N symmetric -C covariance matrix of the solution parameters, -C provided this was requested on input with -C the option vector PRGOPT(*) and the output -C flag is returned with MODE = 0 or 1. -C -C IP(*) The integer working array has three entries -C that provide rank and working array length -C information after completion. -C -C IP(1) = rank of equality constraint -C matrix. Define this quantity -C as KRANKE. -C -C IP(2) = rank of reduced least squares -C problem. -C -C IP(3) = the amount of storage in the -C working array WS(*) that was -C actually used by the subprogram. -C The formula given above for the length -C of WS(*) is a necessary overestimate. -C If exactly the same problem matrices -C are used in subsequent executions, -C the declared dimension of WS(*) can -C be reduced to this output value. -C User Designated -C Working Arrays.. -C -C WS(*),IP(*) These are respectively type real -C and type integer working arrays. -C Their required minimal lengths are -C given above. -C -C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Report SAND77-0552, Sandia -C Laboratories, June 1978. -C K. H. Haskell and R. J. Hanson, Selected algorithms for -C the linearly constrained least squares problem - a -C users guide, Report SAND78-1290, Sandia Laboratories, -C August 1979. -C K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Mathematical Programming -C 21 (1981), pp. 98-118. -C R. J. Hanson and K. H. Haskell, Two algorithms for the -C linearly constrained least squares problem, ACM -C Transactions on Mathematical Software, September 1982. -C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, -C DNRM2, DSCAL, DSWAP, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and extensively revised (WRB & RWC) -C 890831 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 900604 DP version created from SP version. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Removed prints and replaced DP --> REAL(KIND=R8). (THC) -C***END PROLOGUE DLSEI - USE REAL_PRECISION - - INTEGER IP(3), MA, MDW, ME, MG, MODE, N - REAL(KIND=R8) PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*) -C - EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, DNRM2, - * DSCAL, DSWAP - REAL(KIND=R8) D1MACH, DASUM, DDOT, DNRM2 -C - REAL(KIND=R8) DRELPR, ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, - * SN, SNMAX, T, TAU, UJ, UP, VJ, XNORM, XNRME - INTEGER I, IMAX, J, JP1, K, KEY, KRANKE, LAST, LCHK, LINK, M, - * MAPKE1, MDEQC, MEND, MEP1, N1, N2, NEXT, NLINK, NOPT, NP1, - * NTIMES - LOGICAL COV, FIRST -C CHARACTER*8 XERN1, XERN2, XERN3, XERN4 - SAVE FIRST, DRELPR -C - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DLSEI -C -C Set the nominal tolerance used in the code for the equality -C constraint equations. -C - IF (FIRST) DRELPR = D1MACH(4) - FIRST = .FALSE. - TAU = SQRT(DRELPR) -C -C Check that enough storage was allocated in WS(*) and IP(*). -C - MODE = 4 - IF (MIN(N,ME,MA,MG) .LT. 0) THEN -C WRITE (XERN1, '(I8)') N -C WRITE (XERN2, '(I8)') ME -C WRITE (XERN3, '(I8)') MA -C WRITE (XERN4, '(I8)') MG -C CALL XERMSG ('SLATEC', 'LSEI', 'ALL OF THE VARIABLES N, ME,' // -C * ' MA, MG MUST BE .GE. 0$$ENTERED ROUTINE WITH' // -C * '$$N = ' // XERN1 // -C * '$$ME = ' // XERN2 // -C * '$$MA = ' // XERN3 // -C * '$$MG = ' // XERN4, 2, 1) - RETURN - ENDIF -C - IF (IP(1).GT.0) THEN - LCHK = 2*(ME+N) + MAX(MA+MG,N) + (MG+2)*(N+7) - IF (IP(1).LT.LCHK) THEN -C WRITE (XERN1, '(I8)') LCHK -C CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // -C * 'ALLOCATED FOR WS(*), NEED LW = ' // XERN1, 2, 1) - RETURN - ENDIF - ENDIF -C - IF (IP(2).GT.0) THEN - LCHK = MG + 2*N + 2 - IF (IP(2).LT.LCHK) THEN -C WRITE (XERN1, '(I8)') LCHK -C CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // -C * 'ALLOCATED FOR IP(*), NEED LIP = ' // XERN1, 2, 1) - RETURN - ENDIF - ENDIF -C -C Compute number of possible right multiplying Householder -C transformations. -C - M = ME + MA + MG - IF (N.LE.0 .OR. M.LE.0) THEN - MODE = 0 - RNORME = 0 - RNORML = 0 - RETURN - ENDIF -C - IF (MDW.LT.M) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', 'MDW.LT.ME+MA+MG IS AN ERROR', -C + 2, 1) - RETURN - ENDIF -C - NP1 = N + 1 - KRANKE = MIN(ME,N) - N1 = 2*KRANKE + 1 - N2 = N1 + N -C -C Set nominal values. -C -C The nominal column scaling used in the code is -C the identity scaling. -C - CALL DCOPY (N, 1.D0, 0, WS(N1), 1) -C -C No covariance matrix is nominally computed. -C - COV = .FALSE. -C -C Process option vector. -C Define bound for number of options to change. -C - NOPT = 1000 - NTIMES = 0 -C -C Define bound for positive values of LINK. -C - NLINK = 100000 - LAST = 1 - LINK = PRGOPT(1) - IF (LINK.EQ.0 .OR. LINK.GT.NLINK) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', -C + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) - RETURN - ENDIF -C - 100 IF (LINK.GT.1) THEN - NTIMES = NTIMES + 1 - IF (NTIMES.GT.NOPT) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', -C + 'THE LINKS IN THE OPTION VECTOR ARE CYCLING.', 2, 1) - RETURN - ENDIF -C - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.1) THEN - COV = PRGOPT(LAST+2) .NE. 0.D0 - ELSEIF (KEY.EQ.2 .AND. PRGOPT(LAST+2).NE.0.D0) THEN - DO 110 J = 1,N - T = DNRM2(M,W(1,J),1) - IF (T.NE.0.D0) T = 1.D0/T - WS(J+N1-1) = T - 110 CONTINUE - ELSEIF (KEY.EQ.3) THEN - CALL DCOPY (N, PRGOPT(LAST+2), 1, WS(N1), 1) - ELSEIF (KEY.EQ.4) THEN - TAU = MAX(DRELPR,PRGOPT(LAST+2)) - ENDIF -C - NEXT = PRGOPT(LINK) - IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', -C + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) - RETURN - ENDIF -C - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C - DO 120 J = 1,N - CALL DSCAL (M, WS(N1+J-1), W(1,J), 1) - 120 CONTINUE -C - IF (COV .AND. MDW.LT.N) THEN -C CALL XERMSG ('SLATEC', 'DLSEI', -C + 'MDW .LT. N WHEN COV MATRIX NEEDED, IS AN ERROR', 2, 1) - RETURN - ENDIF -C -C Problem definition and option vector OK. -C - MODE = 0 -C -C Compute norm of equality constraint matrix and right side. -C - ENORM = 0.D0 - DO 130 J = 1,N - ENORM = MAX(ENORM,DASUM(ME,W(1,J),1)) - 130 CONTINUE -C - FNORM = DASUM(ME,W(1,NP1),1) - SNMAX = 0.D0 - RNMAX = 0.D0 - DO 150 I = 1,KRANKE -C -C Compute maximum ratio of vector lengths. Partition is at -C column I. -C - DO 140 K = I,ME - SN = DDOT(N-I+1,W(K,I),MDW,W(K,I),MDW) - RN = DDOT(I-1,W(K,1),MDW,W(K,1),MDW) - IF (RN.EQ.0.D0 .AND. SN.GT.SNMAX) THEN - SNMAX = SN - IMAX = K - ELSEIF (K.EQ.I .OR. SN*RNMAX.GT.RN*SNMAX) THEN - SNMAX = SN - RNMAX = RN - IMAX = K - ENDIF - 140 CONTINUE -C -C Interchange rows if necessary. -C - IF (I.NE.IMAX) CALL DSWAP (NP1, W(I,1), MDW, W(IMAX,1), MDW) - IF (SNMAX.GT.RNMAX*TAU**2) THEN -C -C Eliminate elements I+1,...,N in row I. -C - CALL DH12 (1, I, I+1, N, W(I,1), MDW, WS(I), W(I+1,1), MDW, - + 1, M-I) - ELSE - KRANKE = I - 1 - GO TO 160 - ENDIF - 150 CONTINUE -C -C Save diagonal terms of lower trapezoidal matrix. -C - 160 CALL DCOPY (KRANKE, W, MDW+1, WS(KRANKE+1), 1) -C -C Use Householder transformation from left to achieve -C KRANKE by KRANKE upper triangular form. -C - IF (KRANKE.LT.ME) THEN - DO 170 K = KRANKE,1,-1 -C -C Apply transformation to matrix cols. 1,...,K-1. -C - CALL DH12 (1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, - * K-1) -C -C Apply to rt side vector. -C - CALL DH12 (2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, - + 1, 1) - 170 CONTINUE - ENDIF -C -C Solve for variables 1,...,KRANKE in new coordinates. -C - CALL DCOPY (KRANKE, W(1, NP1), 1, X, 1) - DO 180 I = 1,KRANKE - X(I) = (X(I)-DDOT(I-1,W(I,1),MDW,X,1))/W(I,I) - 180 CONTINUE -C -C Compute residuals for reduced problem. -C - MEP1 = ME + 1 - RNORML = 0.D0 - DO 190 I = MEP1,M - W(I,NP1) = W(I,NP1) - DDOT(KRANKE,W(I,1),MDW,X,1) - SN = DDOT(KRANKE,W(I,1),MDW,W(I,1),MDW) - RN = DDOT(N-KRANKE,W(I,KRANKE+1),MDW,W(I,KRANKE+1),MDW) - IF (RN.LE.SN*TAU**2 .AND. KRANKE.LT.N) - * CALL DCOPY (N-KRANKE, 0.D0, 0, W(I,KRANKE+1), MDW) - 190 CONTINUE -C -C Compute equality constraint equations residual length. -C - RNORME = DNRM2(ME-KRANKE,W(KRANKE+1,NP1),1) -C -C Move reduced problem data upward if KRANKE.LT.ME. -C - IF (KRANKE.LT.ME) THEN - DO 200 J = 1,NP1 - CALL DCOPY (M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1) - 200 CONTINUE - ENDIF -C -C Compute solution of reduced problem. -C - CALL DLSI(W(KRANKE+1, KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT, - + X(KRANKE+1), RNORML, MODE, WS(N2), IP(2)) -C -C Test for consistency of equality constraints. -C - IF (ME.GT.0) THEN - MDEQC = 0 - XNRME = DASUM(KRANKE,W(1,NP1),1) - IF (RNORME.GT.TAU*(ENORM*XNRME+FNORM)) MDEQC = 1 - MODE = MODE + MDEQC -C -C Check if solution to equality constraints satisfies inequality -C constraints when there are no degrees of freedom left. -C - IF (KRANKE.EQ.N .AND. MG.GT.0) THEN - XNORM = DASUM(N,X,1) - MAPKE1 = MA + KRANKE + 1 - MEND = MA + KRANKE + MG - DO 210 I = MAPKE1,MEND - SIZE = DASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1)) - IF (W(I,NP1).GT.TAU*SIZE) THEN - MODE = MODE + 2 - GO TO 290 - ENDIF - 210 CONTINUE - ENDIF - ENDIF -C -C Replace diagonal terms of lower trapezoidal matrix. -C - IF (KRANKE.GT.0) THEN - CALL DCOPY (KRANKE, WS(KRANKE+1), 1, W, MDW+1) -C -C Reapply transformation to put solution in original coordinates. -C - DO 220 I = KRANKE,1,-1 - CALL DH12 (2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1) - 220 CONTINUE -C -C Compute covariance matrix of equality constrained problem. -C - IF (COV) THEN - DO 270 J = MIN(KRANKE,N-1),1,-1 - RB = WS(J)*W(J,J) - IF (RB.NE.0.D0) RB = 1.D0/RB - JP1 = J + 1 - DO 230 I = JP1,N - W(I,J) = RB*DDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW) - 230 CONTINUE -C - GAM = 0.5D0*RB*DDOT(N-J,W(JP1,J),1,W(J,JP1),MDW) - CALL DAXPY (N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1) - DO 250 I = JP1,N - DO 240 K = I,N - W(I,K) = W(I,K) + W(J,I)*W(K,J) + W(I,J)*W(J,K) - W(K,I) = W(I,K) - 240 CONTINUE - 250 CONTINUE - UJ = WS(J) - VJ = GAM*UJ - W(J,J) = UJ*VJ + UJ*VJ - DO 260 I = JP1,N - W(J,I) = UJ*W(I,J) + VJ*W(J,I) - 260 CONTINUE - CALL DCOPY (N-J, W(J, JP1), MDW, W(JP1,J), 1) - 270 CONTINUE - ENDIF - ENDIF -C -C Apply the scaling to the covariance matrix. -C - IF (COV) THEN - DO 280 I = 1,N - CALL DSCAL (N, WS(I+N1-1), W(I,1), MDW) - CALL DSCAL (N, WS(I+N1-1), W(1,I), 1) - 280 CONTINUE - ENDIF -C -C Rescale solution vector. -C - 290 IF (MODE.LE.1) THEN - DO 300 J = 1,N - X(J) = X(J)*WS(N1+J-1) - 300 CONTINUE - ENDIF -C - IP(1) = KRANKE - IP(3) = IP(3) + 2*KRANKE + N - RETURN - END -*DECK DLSI - SUBROUTINE DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, - + IP) -C***BEGIN PROLOGUE DLSI -C***SUBSIDIARY -C***PURPOSE Subsidiary to DLSEI -C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (LSI-S, DLSI-D) -C***AUTHOR Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to DLSEI. The documentation for -C DLSEI has complete usage instructions. -C -C Solve.. -C AX = B, A MA by N (least squares equations) -C subject to.. -C -C GX.GE.H, G MG by N (inequality constraints) -C -C Input.. -C -C W(*,*) contains (A B) in rows 1,...,MA+MG, cols 1,...,N+1. -C (G H) -C -C MDW,MA,MG,N -C contain (resp) var. dimension of W(*,*), -C and matrix dimensions. -C -C PRGOPT(*), -C Program option vector. -C -C OUTPUT.. -C -C X(*),RNORM -C -C Solution vector(unless MODE=2), length of AX-B. -C -C MODE -C =0 Inequality constraints are compatible. -C =2 Inequality constraints contradictory. -C -C WS(*), -C Working storage of dimension K+N+(MG+2)*(N+7), -C where K=MAX(MA+MG,N). -C IP(MG+2*N+1) -C Integer working storage -C -C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, -C DLPDP, DSCAL, DSWAP -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and extensively revised (WRB & RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900604 DP version created from SP version. (RWC) -C 920422 Changed CALL to DHFTI to include variable MA. (WRB) -C***END PROLOGUE DLSI - USE REAL_PRECISION - - INTEGER IP(*), MA, MDW, MG, MODE, N - REAL(KIND=R8) PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*) -C - EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, DLPDP, - * DSCAL, DSWAP - REAL(KIND=R8) D1MACH, DASUM, DDOT -C - REAL(KIND=R8) ANORM, DRELPR, FAC, GAM, RB, TAU, TOL, XNORM, - * TMP_NORM(1) - INTEGER I, J, K, KEY, KRANK, KRM1, KRP1, L, LAST, LINK, M, MAP1, - * MDLPDP, MINMAN, N1, N2, N3, NEXT, NP1 - LOGICAL COV, FIRST, SCLCOV -C - SAVE DRELPR, FIRST - DATA FIRST /.TRUE./ -C -C***FIRST EXECUTABLE STATEMENT DLSI -C -C Set the nominal tolerance used in the code. -C - IF (FIRST) DRELPR = D1MACH(4) - FIRST = .FALSE. - TOL = SQRT(DRELPR) -C - MODE = 0 - RNORM = 0.D0 - M = MA + MG - NP1 = N + 1 - KRANK = 0 - IF (N.LE.0 .OR. M.LE.0) GO TO 370 -C -C To process option vector. -C - COV = .FALSE. - SCLCOV = .TRUE. - LAST = 1 - LINK = PRGOPT(1) -C - 100 IF (LINK.GT.1) THEN - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.1) COV = PRGOPT(LAST+2) .NE. 0.D0 - IF (KEY.EQ.10) SCLCOV = PRGOPT(LAST+2) .EQ. 0.D0 - IF (KEY.EQ.5) TOL = MAX(DRELPR,PRGOPT(LAST+2)) - NEXT = PRGOPT(LINK) - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C -C Compute matrix norm of least squares equations. -C - ANORM = 0.D0 - DO 110 J = 1,N - ANORM = MAX(ANORM,DASUM(MA,W(1,J),1)) - 110 CONTINUE -C -C Set tolerance for DHFTI( ) rank test. -C - TAU = TOL*ANORM -C -C Compute Householder orthogonal decomposition of matrix. -C - CALL DCOPY (N, 0.D0, 0, WS, 1) - CALL DCOPY (MA, W(1, NP1), 1, WS, 1) - K = MAX(M,N) - MINMAN = MIN(MA,N) - N1 = K + 1 - N2 = N1 + N - CALL DHFTI (W, MDW, MA, N, WS, MA, 1, TAU, KRANK, TMP_NORM, - + WS(N2), WS(N1), IP) - RNORM = TMP_NORM(1) - FAC = 1.D0 - GAM = MA - KRANK - IF (KRANK.LT.MA .AND. SCLCOV) FAC = RNORM**2/GAM -C -C Reduce to DLPDP and solve. -C - MAP1 = MA + 1 -C -C Compute inequality rt-hand side for DLPDP. -C - IF (MA.LT.M) THEN - IF (MINMAN.GT.0) THEN - DO 120 I = MAP1,M - W(I,NP1) = W(I,NP1) - DDOT(N,W(I,1),MDW,WS,1) - 120 CONTINUE -C -C Apply permutations to col. of inequality constraint matrix. -C - DO 130 I = 1,MINMAN - CALL DSWAP (MG, W(MAP1,I), 1, W(MAP1,IP(I)), 1) - 130 CONTINUE -C -C Apply Householder transformations to constraint matrix. -C - IF (KRANK.GT.0 .AND. KRANK.LT.N) THEN - DO 140 I = KRANK,1,-1 - CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), - + W(MAP1,1), MDW, 1, MG) - 140 CONTINUE - ENDIF -C -C Compute permuted inequality constraint matrix times r-inv. -C - DO 160 I = MAP1,M - DO 150 J = 1,KRANK - W(I,J) = (W(I,J)-DDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J) - 150 CONTINUE - 160 CONTINUE - ENDIF -C -C Solve the reduced problem with DLPDP algorithm, -C the least projected distance problem. -C - CALL DLPDP(W(MAP1,1), MDW, MG, KRANK, N-KRANK, PRGOPT, X, - + XNORM, MDLPDP, WS(N2), IP(N+1)) -C -C Compute solution in original coordinates. -C - IF (MDLPDP.EQ.1) THEN - DO 170 I = KRANK,1,-1 - X(I) = (X(I)-DDOT(KRANK-I,W(I,I+1),MDW,X(I+1),1))/W(I,I) - 170 CONTINUE -C -C Apply Householder transformation to solution vector. -C - IF (KRANK.LT.N) THEN - DO 180 I = 1,KRANK - CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), - + X, 1, 1, 1) - 180 CONTINUE - ENDIF -C -C Repermute variables to their input order. -C - IF (MINMAN.GT.0) THEN - DO 190 I = MINMAN,1,-1 - CALL DSWAP (1, X(I), 1, X(IP(I)), 1) - 190 CONTINUE -C -C Variables are now in original coordinates. -C Add solution of unconstrained problem. -C - DO 200 I = 1,N - X(I) = X(I) + WS(I) - 200 CONTINUE -C -C Compute the residual vector norm. -C - RNORM = SQRT(RNORM**2+XNORM**2) - ENDIF - ELSE - MODE = 2 - ENDIF - ELSE - CALL DCOPY (N, WS, 1, X, 1) - ENDIF -C -C Compute covariance matrix based on the orthogonal decomposition -C from DHFTI( ). -C - IF (.NOT.COV .OR. KRANK.LE.0) GO TO 370 - KRM1 = KRANK - 1 - KRP1 = KRANK + 1 -C -C Copy diagonal terms to working array. -C - CALL DCOPY (KRANK, W, MDW+1, WS(N2), 1) -C -C Reciprocate diagonal terms. -C - DO 210 J = 1,KRANK - W(J,J) = 1.D0/W(J,J) - 210 CONTINUE -C -C Invert the upper triangular QR factor on itself. -C - IF (KRANK.GT.1) THEN - DO 230 I = 1,KRM1 - DO 220 J = I+1,KRANK - W(I,J) = -DDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J) - 220 CONTINUE - 230 CONTINUE - ENDIF -C -C Compute the inverted factor times its transpose. -C - DO 250 I = 1,KRANK - DO 240 J = I,KRANK - W(I,J) = DDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW) - 240 CONTINUE - 250 CONTINUE -C -C Zero out lower trapezoidal part. -C Copy upper triangular to lower triangular part. -C - IF (KRANK.LT.N) THEN - DO 260 J = 1,KRANK - CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) - 260 CONTINUE -C - DO 270 I = KRP1,N - CALL DCOPY (I, 0.D0, 0, W(I,1), MDW) - 270 CONTINUE -C -C Apply right side transformations to lower triangle. -C - N3 = N2 + KRP1 - DO 330 I = 1,KRANK - L = N1 + I - K = N2 + I - RB = WS(L-1)*WS(K-1) -C -C If RB.GE.0.D0, transformation can be regarded as zero. -C - IF (RB.LT.0.D0) THEN - RB = 1.D0/RB -C -C Store unscaled rank one Householder update in work array. -C - CALL DCOPY (N, 0.D0, 0, WS(N3), 1) - L = N1 + I - K = N3 + I - WS(K-1) = WS(L-1) -C - DO 280 J = KRP1,N - WS(N3+J-1) = W(I,J) - 280 CONTINUE -C - DO 290 J = 1,N - WS(J) = RB*(DDOT(J-I,W(J,I),MDW,WS(N3+I-1),1)+ - + DDOT(N-J+1,W(J,J),1,WS(N3+J-1),1)) - 290 CONTINUE -C - L = N3 + I - GAM = 0.5D0*RB*DDOT(N-I+1,WS(L-1),1,WS(I),1) - CALL DAXPY (N-I+1, GAM, WS(L-1), 1, WS(I), 1) - DO 320 J = I,N - DO 300 L = 1,I-1 - W(J,L) = W(J,L) + WS(N3+J-1)*WS(L) - 300 CONTINUE -C - DO 310 L = I,J - W(J,L) = W(J,L) + WS(J)*WS(N3+L-1)+WS(L)*WS(N3+J-1) - 310 CONTINUE - 320 CONTINUE - ENDIF - 330 CONTINUE -C -C Copy lower triangle to upper triangle to symmetrize the -C covariance matrix. -C - DO 340 I = 1,N - CALL DCOPY (I, W(I,1), MDW, W(1,I), 1) - 340 CONTINUE - ENDIF -C -C Repermute rows and columns. -C - DO 350 I = MINMAN,1,-1 - K = IP(I) - IF (I.NE.K) THEN - CALL DSWAP (1, W(I,I), 1, W(K,K), 1) - CALL DSWAP (I-1, W(1,I), 1, W(1,K), 1) - CALL DSWAP (K-I-1, W(I,I+1), MDW, W(I+1,K), 1) - CALL DSWAP (N-K, W(I, K+1), MDW, W(K, K+1), MDW) - ENDIF - 350 CONTINUE -C -C Put in normalized residual sum of squares scale factor -C and symmetrize the resulting covariance matrix. -C - DO 360 J = 1,N - CALL DSCAL (J, FAC, W(1,J), 1) - CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) - 360 CONTINUE -C - 370 IP(1) = KRANK - IP(2) = N + MAX(M,N) + (MG+2)*(N+7) - RETURN - END -*DECK D1MACH - REAL(KIND=R8) FUNCTION D1MACH (I) -C***BEGIN PROLOGUE D1MACH -C***PURPOSE Return floating point machine dependent constants. -C***LIBRARY SLATEC -C***CATEGORY R1 -C***TYPE REAL(KIND=R8) (R1MACH-S, D1MACH-D) -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR Fox, P. A., (Bell Labs) -C Hall, A. D., (Bell Labs) -C Schryer, N. L., (Bell Labs) -C***DESCRIPTION -C -C D1MACH can be used to obtain machine-dependent parameters for the -C local machine environment. It is a function subprogram with one -C (input) argument, and can be referenced as follows: -C -C D = D1MACH(I) -C -C where I=1,...,5. The (output) value of D above is determined by -C the (input) value of I. The results for various values of I are -C discussed below. -C -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 Assume double precision numbers are represented in the T-digit, -C base-B form -C -C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C -C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and -C EMIN .LE. E .LE. EMAX. -C -C The values of B, T, EMIN and EMAX are provided in I1MACH as -C follows: -C I1MACH(10) = B, the base. -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 -C To alter this function for a particular environment, the desired -C set of DATA statements should be activated by removing the C from -C column 1. Also, the values of D1MACH(1) - D1MACH(4) should be -C checked for consistency with the local operating system. -C -C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for -C a portable library, ACM Transactions on Mathematical -C Software 4, 2 (June 1978), pp. 177-188. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 890213 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900618 Added DEC RISC constants. (WRB) -C 900723 Added IBM RS 6000 constants. (WRB) -C 900911 Added SUN 386i constants. (WRB) -C 910710 Added HP 730 constants. (SMR) -C 911114 Added Convex IEEE constants. (WRB) -C 920121 Added SUN -r8 compiler option constants. (WRB) -C 920229 Added Touchstone Delta i860 constants. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920625 Added CONVEX -p8 and -pd8 compiler option constants. -C (BKS, WRB) -C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) -C 010817 Elevated IEEE to highest importance; see next set of -C comments below. (DWL) -C***END PROLOGUE D1MACH -C - USE REAL_PRECISION - - INTEGER SMALL(4) - INTEGER LARGE(4) - INTEGER RIGHT(4) - INTEGER DIVER(4) - INTEGER LOG10(4) -C -C Initial data here correspond to the IEEE standard. The values for -C DMACH(1), DMACH(3) and DMACH(4) are slight upper bounds. The value -C for DMACH(2) is a slight lower bound. The value for DMACH(5) is -C a 20-digit approximation. If one of the sets of initial data below -C is preferred, do the necessary commenting and uncommenting. (DWL) - REAL(KIND=R8) DMACH(5) - DATA DMACH / 2.23D-308, 1.79D+308, 1.111D-16, 2.222D-16, - 1 0.30102999566398119521D0 / - SAVE DMACH -C - 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 AMIGA -C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE APOLLO -C -C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / -C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / -C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / -C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM -C -C DATA SMALL(1) / ZC00800000 / -C DATA SMALL(2) / Z000000000 / -C DATA LARGE(1) / ZDFFFFFFFF / -C DATA LARGE(2) / ZFFFFFFFFF / -C DATA RIGHT(1) / ZCC5800000 / -C DATA RIGHT(2) / Z000000000 / -C DATA DIVER(1) / ZCC6800000 / -C DATA DIVER(2) / Z000000000 / -C DATA LOG10(1) / ZD00E730E7 / -C DATA LOG10(2) / ZC77800DC0 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM -C -C DATA SMALL(1) / O1771000000000000 / -C DATA SMALL(2) / O0000000000000000 / -C DATA LARGE(1) / O0777777777777777 / -C DATA LARGE(2) / O0007777777777777 / -C DATA RIGHT(1) / O1461000000000000 / -C DATA RIGHT(2) / O0000000000000000 / -C DATA DIVER(1) / O1451000000000000 / -C DATA DIVER(2) / O0000000000000000 / -C DATA LOG10(1) / O1157163034761674 / -C DATA LOG10(2) / O0006677466732724 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS -C -C DATA SMALL(1) / O1771000000000000 / -C DATA SMALL(2) / O7770000000000000 / -C DATA LARGE(1) / O0777777777777777 / -C DATA LARGE(2) / O7777777777777777 / -C DATA RIGHT(1) / O1461000000000000 / -C DATA RIGHT(2) / O0000000000000000 / -C DATA DIVER(1) / O1451000000000000 / -C DATA DIVER(2) / O0000000000000000 / -C DATA LOG10(1) / O1157163034761674 / -C DATA LOG10(2) / O0006677466732724 / -C -C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE -C -C DATA SMALL(1) / Z"3001800000000000" / -C DATA SMALL(2) / Z"3001000000000000" / -C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / -C DATA LARGE(2) / Z"4FFE000000000000" / -C DATA RIGHT(1) / Z"3FD2800000000000" / -C DATA RIGHT(2) / Z"3FD2000000000000" / -C DATA DIVER(1) / Z"3FD3800000000000" / -C DATA DIVER(2) / Z"3FD3000000000000" / -C DATA LOG10(1) / Z"3FFF9A209A84FBCF" / -C DATA LOG10(2) / Z"3FFFF7988F8959AC" / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES -C -C DATA SMALL(1) / 00564000000000000000B / -C DATA SMALL(2) / 00000000000000000000B / -C DATA LARGE(1) / 37757777777777777777B / -C DATA LARGE(2) / 37157777777777777777B / -C DATA RIGHT(1) / 15624000000000000000B / -C DATA RIGHT(2) / 00000000000000000000B / -C DATA DIVER(1) / 15634000000000000000B / -C DATA DIVER(2) / 00000000000000000000B / -C DATA LOG10(1) / 17164642023241175717B / -C DATA LOG10(2) / 16367571421742254654B / -C -C MACHINE CONSTANTS FOR THE CELERITY C1260 -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fn OR -pd8 COMPILER OPTION -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CC0000000000000' / -C DATA DMACH(4) / Z'3CD0000000000000' / -C DATA DMACH(5) / Z'3FF34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fi COMPILER OPTION -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -p8 COMPILER OPTION -C -C DATA DMACH(1) / Z'00010000000000000000000000000000' / -C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3F900000000000000000000000000000' / -C DATA DMACH(4) / Z'3F910000000000000000000000000000' / -C DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / -C -C MACHINE CONSTANTS FOR THE CRAY -C -C DATA SMALL(1) / 201354000000000000000B / -C DATA SMALL(2) / 000000000000000000000B / -C DATA LARGE(1) / 577767777777777777777B / -C DATA LARGE(2) / 000007777777777777774B / -C DATA RIGHT(1) / 376434000000000000000B / -C DATA RIGHT(2) / 000000000000000000000B / -C DATA DIVER(1) / 376444000000000000000B / -C DATA DIVER(2) / 000000000000000000000B / -C DATA LOG10(1) / 377774642023241175717B / -C DATA LOG10(2) / 000007571421742254654B / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - -C STATIC DMACH(5) -C -C DATA SMALL / 20K, 3*0 / -C DATA LARGE / 77777K, 3*177777K / -C DATA RIGHT / 31420K, 3*0 / -C DATA DIVER / 32020K, 3*0 / -C DATA LOG10 / 40423K, 42023K, 50237K, 74776K / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING G_FLOAT -C -C DATA DMACH(1) / '0000000000000010'X / -C DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / -C DATA DMACH(3) / '0000000000003CC0'X / -C DATA DMACH(4) / '0000000000003CD0'X / -C DATA DMACH(5) / '79FF509F44133FF3'X / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING IEEE_FORMAT -C -C DATA DMACH(1) / '0010000000000000'X / -C DATA DMACH(2) / '7FEFFFFFFFFFFFFF'X / -C DATA DMACH(3) / '3CA0000000000000'X / -C DATA DMACH(4) / '3CB0000000000000'X / -C DATA DMACH(5) / '3FD34413509F79FF'X / -C -C MACHINE CONSTANTS FOR THE DEC RISC -C -C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ -C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ -C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ -C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ -C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING D_FLOATING -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS -C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS -C -C DATA SMALL(1), SMALL(2) / 128, 0 / -C DATA LARGE(1), LARGE(2) / -32769, -1 / -C DATA RIGHT(1), RIGHT(2) / 9344, 0 / -C DATA DIVER(1), DIVER(2) / 9472, 0 / -C DATA LOG10(1), LOG10(2) / 546979738, -805796613 / -C -C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / -C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING G_FLOATING -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS -C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS -C -C DATA SMALL(1), SMALL(2) / 16, 0 / -C DATA LARGE(1), LARGE(2) / -32769, -1 / -C DATA RIGHT(1), RIGHT(2) / 15552, 0 / -C DATA DIVER(1), DIVER(2) / 15568, 0 / -C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / -C -C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / -C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / -C -C MACHINE CONSTANTS FOR THE ELXSI 6400 -C (ASSUMING REAL*8 IS THE DEFAULT REAL(KIND=R8)) -C -C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / -C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / -C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / -C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / -C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C -C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / -C DATA LARGE(1), LARGE(2) / '37777777, '37777577 / -C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / -C DATA DIVER(1), DIVER(2) / '20000000, '00000334 / -C DATA LOG10(1), LOG10(2) / '23210115, '10237777 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES -C -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 / -C -C MACHINE CONSTANTS FOR THE HP 730 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C THREE WORD REAL(KIND=R8) OPTION WITH FTN4 -C -C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / -C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / -C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / -C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / -C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C FOUR WORD REAL(KIND=R8) OPTION WITH FTN4 -C -C DATA SMALL(1), SMALL(2) / 40000B, 0 / -C DATA SMALL(3), SMALL(4) / 0, 1 / -C DATA LARGE(1), LARGE(2) / 77777B, 177777B / -C DATA LARGE(3), LARGE(4) / 177777B, 177776B / -C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / -C DATA RIGHT(3), RIGHT(4) / 0, 225B / -C DATA DIVER(1), DIVER(2) / 40000B, 0 / -C DATA DIVER(3), DIVER(4) / 0, 227B / -C DATA LOG10(1), LOG10(2) / 46420B, 46502B / -C DATA LOG10(3), LOG10(4) / 76747B, 176377B / -C -C MACHINE CONSTANTS FOR THE HP 9000 -C -C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / -C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / -C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / -C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / -C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND -C THE PERKIN ELMER (INTERDATA) 7/32. -C -C DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / -C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / -C -C MACHINE CONSTANTS FOR THE IBM PC -C ASSUMES THAT ALL ARITHMETIC IS DONE IN REAL(KIND=R8) -C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. -C -C DATA SMALL(1) / 2.23D-308 / -C DATA LARGE(1) / 1.79D+308 / -C DATA RIGHT(1) / 1.11D-16 / -C DATA DIVER(1) / 2.22D-16 / -C DATA LOG10(1) / 0.301029995663981195D0 / -C -C MACHINE CONSTANTS FOR THE IBM RS 6000 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE INTEL i860 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) -C -C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / -C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / -C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / -C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / -C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) -C -C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / -C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / -C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / -C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / -C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -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 / -C -C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / -C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / -C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / -C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / -C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA SMALL(1), SMALL(2) / 128, 0 / -C DATA SMALL(3), SMALL(4) / 0, 0 / -C DATA LARGE(1), LARGE(2) / 32767, -1 / -C DATA LARGE(3), LARGE(4) / -1, -1 / -C DATA RIGHT(1), RIGHT(2) / 9344, 0 / -C DATA RIGHT(3), RIGHT(4) / 0, 0 / -C DATA DIVER(1), DIVER(2) / 9472, 0 / -C DATA DIVER(3), DIVER(4) / 0, 0 / -C DATA LOG10(1), LOG10(2) / 16282, 8346 / -C DATA LOG10(3), LOG10(4) / -31493, -12296 / -C -C DATA SMALL(1), SMALL(2) / O000200, O000000 / -C DATA SMALL(3), SMALL(4) / O000000, O000000 / -C DATA LARGE(1), LARGE(2) / O077777, O177777 / -C DATA LARGE(3), LARGE(4) / O177777, O177777 / -C DATA RIGHT(1), RIGHT(2) / O022200, O000000 / -C DATA RIGHT(3), RIGHT(4) / O000000, O000000 / -C DATA DIVER(1), DIVER(2) / O022400, O000000 / -C DATA DIVER(3), DIVER(4) / O000000, O000000 / -C DATA LOG10(1), LOG10(2) / O037632, O020232 / -C DATA LOG10(3), LOG10(4) / O102373, O147770 / -C -C MACHINE CONSTANTS FOR THE SILICON GRAPHICS -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE SUN -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE SUN -C USING THE -r8 COMPILER OPTION -C -C DATA DMACH(1) / Z'00010000000000000000000000000000' / -C DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / -C DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / -C DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / -C -C MACHINE CONSTANTS FOR THE SUN 386i -C -C DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / -C DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / -C DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' -C DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER -C -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 / -C -C***FIRST EXECUTABLE STATEMENT D1MACH -C IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'D1MACH', -C + 'I OUT OF BOUNDS', 1, 2) -C - D1MACH = DMACH(I) - RETURN -C - END -*DECK I1MACH - INTEGER FUNCTION I1MACH (I) -C***BEGIN PROLOGUE I1MACH -C***PURPOSE Return integer machine dependent constants. -C***LIBRARY SLATEC -C***CATEGORY R1 -C***TYPE INTEGER (I1MACH-I) -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR Fox, P. A., (Bell Labs) -C Hall, A. D., (Bell Labs) -C Schryer, N. L., (Bell Labs) -C***DESCRIPTION -C -C I1MACH can be used to obtain machine-dependent parameters for the -C local machine environment. It is a function subprogram with one -C (input) argument and can be referenced as follows: -C -C K = I1MACH(I) -C -C where I=1,...,16. The (output) value of K above is determined by -C the (input) value of I. The results for various values of I are -C discussed below. -C -C I/O unit numbers: -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 -C Words: -C I1MACH( 5) = the number of bits per integer storage unit. -C I1MACH( 6) = the number of characters per integer storage unit. -C -C Integers: -C assume integers are represented in the S-digit, base-A form -C -C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) -C -C where 0 .LE. X(I) .LT. A for I=0,...,S-1. -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 -C Floating-Point Numbers: -C Assume floating-point numbers are represented in the T-digit, -C base-B form -C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C -C where 0 .LE. X(I) .LT. B for I=1,...,T, -C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. -C I1MACH(10) = B, the base. -C -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 -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 -C To alter this function for a particular environment, the desired -C set of DATA statements should be activated by removing the C from -C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be -C checked for consistency with the local operating system. -C -C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for -C a portable library, ACM Transactions on Mathematical -C Software 4, 2 (June 1978), pp. 177-188. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 891012 Added VAX G-floating constants. (WRB) -C 891012 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900618 Added DEC RISC constants. (WRB) -C 900723 Added IBM RS 6000 constants. (WRB) -C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. -C (RWC) -C 910710 Added HP 730 constants. (SMR) -C 911114 Added Convex IEEE constants. (WRB) -C 920121 Added SUN -r8 compiler option constants. (WRB) -C 920229 Added Touchstone Delta i860 constants. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920625 Added Convex -p8 and -pd8 compiler option constants. -C (BKS, WRB) -C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) -C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler -C options. (DWL, RWC and WRB). -C 010817 Elevated IEEE to highest importance; see next set of -C comments below. (DWL) -C***END PROLOGUE I1MACH -C -C Initial data here correspond to the IEEE standard. If one of the -C sets of initial data below is preferred, do the necessary commenting -C and uncommenting. (DWL) - INTEGER IMACH(16),OUTPUT - DATA IMACH( 1) / 5 / - DATA IMACH( 2) / 6 / - DATA IMACH( 3) / 6 / - DATA IMACH( 4) / 6 / - DATA IMACH( 5) / 32 / - DATA IMACH( 6) / 4 / - DATA IMACH( 7) / 2 / - DATA IMACH( 8) / 31 / - DATA IMACH( 9) / 2147483647 / - DATA IMACH(10) / 2 / - DATA IMACH(11) / 24 / - DATA IMACH(12) / -126 / - DATA IMACH(13) / 127 / - DATA IMACH(14) / 53 / - DATA IMACH(15) / -1022 / - DATA IMACH(16) / 1023 / - SAVE IMACH - EQUIVALENCE (IMACH(4),OUTPUT) -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT COMPILER -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE APOLLO -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 129 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1025 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM -C -C DATA IMACH( 1) / 7 / -C DATA IMACH( 2) / 2 / -C DATA IMACH( 3) / 2 / -C DATA IMACH( 4) / 2 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 33 / -C DATA IMACH( 9) / Z1FFFFFFFF / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -256 / -C DATA IMACH(13) / 255 / -C DATA IMACH(14) / 60 / -C DATA IMACH(15) / -256 / -C DATA IMACH(16) / 255 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM -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) / 48 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 39 / -C DATA IMACH( 9) / O0007777777777777 / -C DATA IMACH(10) / 8 / -C DATA IMACH(11) / 13 / -C DATA IMACH(12) / -50 / -C DATA IMACH(13) / 76 / -C DATA IMACH(14) / 26 / -C DATA IMACH(15) / -50 / -C DATA IMACH(16) / 76 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS -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) / 48 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 39 / -C DATA IMACH( 9) / O0007777777777777 / -C DATA IMACH(10) / 8 / -C DATA IMACH(11) / 13 / -C DATA IMACH(12) / -50 / -C DATA IMACH(13) / 76 / -C DATA IMACH(14) / 26 / -C DATA IMACH(15) / -32754 / -C DATA IMACH(16) / 32780 / -C -C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE -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) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -4095 / -C DATA IMACH(13) / 4094 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -4095 / -C DATA IMACH(16) / 4094 / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6LOUTPUT/ -C DATA IMACH( 5) / 60 / -C DATA IMACH( 6) / 10 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 48 / -C DATA IMACH( 9) / 00007777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -929 / -C DATA IMACH(13) / 1070 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -929 / -C DATA IMACH(16) / 1069 / -C -C MACHINE CONSTANTS FOR THE CELERITY C1260 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 0 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / Z'7FFFFFFF' / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fn COMPILER OPTION -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) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fi COMPILER OPTION -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -p8 COMPILER OPTION -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) / 64 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1023 / -C DATA IMACH(13) / 1023 / -C DATA IMACH(14) / 113 / -C DATA IMACH(15) / -16383 / -C DATA IMACH(16) / 16383 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -pd8 COMPILER OPTION -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) / 64 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1023 / -C DATA IMACH(13) / 1023 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CRAY -C USING THE 46 BIT INTEGER COMPILER OPTION -C -C DATA IMACH( 1) / 100 / -C DATA IMACH( 2) / 101 / -C DATA IMACH( 3) / 102 / -C DATA IMACH( 4) / 101 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 46 / -C DATA IMACH( 9) / 1777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -8189 / -C DATA IMACH(13) / 8190 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -8099 / -C DATA IMACH(16) / 8190 / -C -C MACHINE CONSTANTS FOR THE CRAY -C USING THE 64 BIT INTEGER COMPILER OPTION -C -C DATA IMACH( 1) / 100 / -C DATA IMACH( 2) / 101 / -C DATA IMACH( 3) / 102 / -C DATA IMACH( 4) / 101 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 777777777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -8189 / -C DATA IMACH(13) / 8190 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -8099 / -C DATA IMACH(16) / 8190 / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C -C DATA IMACH( 1) / 11 / -C DATA IMACH( 2) / 12 / -C DATA IMACH( 3) / 8 / -C DATA IMACH( 4) / 10 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING G_FLOAT -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING IEEE_FLOAT -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE DEC RISC -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING D_FLOATING -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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 / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING G_FLOATING -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE ELXSI 6400 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 32 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 24 / -C DATA IMACH( 6) / 3 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 23 / -C DATA IMACH( 9) / 8388607 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 38 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 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) / 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) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 63 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 730 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 3 WORD REAL(KIND=R8) OPTION WITH FTN4 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 4 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 39 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 4 WORD REAL(KIND=R8) OPTION WITH FTN4 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 4 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 55 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 9000 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 7 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 32 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1015 / -C DATA IMACH(16) / 1017 / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND -C THE PERKIN ELMER (INTERDATA) 7/32. -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) / Z7FFFFFFF / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 / -C -C MACHINE CONSTANTS FOR THE IBM PC -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 0 / -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) / -125 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE IBM RS 6000 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 0 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE INTEL i860 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 5 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / "377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 54 / -C DATA IMACH(15) / -101 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 5 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / "377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 62 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGER ARITHMETIC. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -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 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGER ARITHMETIC. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -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 / -C -C MACHINE CONSTANTS FOR THE SILICON GRAPHICS -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE SUN -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE SUN -C USING THE -r8 COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -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) / 53 / -C DATA IMACH(12) / -1021 / -C DATA IMACH(13) / 1024 / -C DATA IMACH(14) / 113 / -C DATA IMACH(15) / -16381 / -C DATA IMACH(16) / 16384 / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 1 / -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) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 60 / -C DATA IMACH(15) / -1024 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR -C -C DATA IMACH( 1) / 1 / -C DATA IMACH( 2) / 1 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -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 / -C -C***FIRST EXECUTABLE STATEMENT I1MACH - IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 -C - I1MACH = IMACH(I) - RETURN -C - 10 CONTINUE - WRITE (UNIT = OUTPUT, FMT = 9000) - 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') -C -C CALL FDUMP -C - STOP - END -*DECK DH12 - SUBROUTINE DH12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV, - + NCV) -C***BEGIN PROLOGUE DH12 -C***SUBSIDIARY -C***PURPOSE Subsidiary to DHFTI, DLSEI and DWNNLS -C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (H12-S, DH12-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C *** REAL(KIND=R8) VERSION OF H12 ****** -C -C C.L.Lawson and R.J.Hanson, Jet Propulsion Laboratory, 1973 Jun 12 -C to appear in 'Solving Least Squares Problems', Prentice-Hall, 1974 -C -C Construction and/or application of a single -C Householder transformation.. Q = I + U*(U**T)/B -C -C MODE = 1 or 2 to select algorithm H1 or H2 . -C LPIVOT is the index of the pivot element. -C L1,M If L1 .LE. M the transformation will be constructed to -C zero elements indexed from L1 through M. If L1 GT. M -C THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. -C U(),IUE,UP On entry to H1 U() contains the pivot vector. -C IUE is the storage increment between elements. -C On exit from H1 U() and UP -C contain quantities defining the vector U of the -C Householder transformation. On entry to H2 U() -C and UP should contain quantities previously computed -C by H1. These will not be modified by H2. -C C() On entry to H1 or H2 C() contains a matrix which will be -C regarded as a set of vectors to which the Householder -C transformation is to be applied. On exit C() contains the -C set of transformed vectors. -C ICE Storage increment between elements of vectors in C(). -C ICV Storage increment between vectors in C(). -C NCV Number of vectors in C() to be transformed. If NCV .LE. 0 -C no operations will be done on C(). -C -C***SEE ALSO DHFTI, DLSEI, DWNNLS -C***ROUTINES CALLED DAXPY, DDOT, DSWAP -C***REVISION HISTORY (YYMMDD) -C 790101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900911 Added DDOT to REAL(KIND=R8) statement. (WRB) -C***END PROLOGUE DH12 - USE REAL_PRECISION - - INTEGER I, I2, I3, I4, ICE, ICV, INCR, IUE, J, KL1, KL2, KLP, - * L1, L1M1, LPIVOT, M, MML1P2, MODE, NCV - REAL(KIND=R8) B, C, CL, CLINV, ONE, UL1M1, SM, U, UP, DDOT - DIMENSION U(IUE,*), C(*) -C BEGIN BLOCK PERMITTING ...EXITS TO 140 -C***FIRST EXECUTABLE STATEMENT DH12 - ONE = 1.0D0 -C -C ...EXIT - IF (0 .GE. LPIVOT .OR. LPIVOT .GE. L1 .OR. L1 .GT. M) GO TO 140 - CL = ABS(U(1,LPIVOT)) - IF (MODE .EQ. 2) GO TO 40 -C ****** CONSTRUCT THE TRANSFORMATION. ****** - DO 10 J = L1, M - CL = MAX(ABS(U(1,J)),CL) - 10 CONTINUE - IF (CL .GT. 0.0D0) GO TO 20 -C .........EXIT - GO TO 140 - 20 CONTINUE - CLINV = ONE/CL - SM = (U(1,LPIVOT)*CLINV)**2 - DO 30 J = L1, M - SM = SM + (U(1,J)*CLINV)**2 - 30 CONTINUE - CL = CL*SQRT(SM) - IF (U(1,LPIVOT) .GT. 0.0D0) CL = -CL - UP = U(1,LPIVOT) - CL - U(1,LPIVOT) = CL - GO TO 50 - 40 CONTINUE -C ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** -C - IF (CL .GT. 0.0D0) GO TO 50 -C ......EXIT - GO TO 140 - 50 CONTINUE -C ...EXIT - IF (NCV .LE. 0) GO TO 140 - B = UP*U(1,LPIVOT) -C B MUST BE NONPOSITIVE HERE. IF B = 0., RETURN. -C - IF (B .LT. 0.0D0) GO TO 60 -C ......EXIT - GO TO 140 - 60 CONTINUE - B = ONE/B - MML1P2 = M - L1 + 2 - IF (MML1P2 .LE. 20) GO TO 80 - L1M1 = L1 - 1 - KL1 = 1 + (L1M1 - 1)*ICE - KL2 = KL1 - KLP = 1 + (LPIVOT - 1)*ICE - UL1M1 = U(1,L1M1) - U(1,L1M1) = UP - IF (LPIVOT .NE. L1M1) CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) - DO 70 J = 1, NCV - SM = DDOT(MML1P2,U(1,L1M1),IUE,C(KL1),ICE) - SM = SM*B - CALL DAXPY(MML1P2,SM,U(1,L1M1),IUE,C(KL1),ICE) - KL1 = KL1 + ICV - 70 CONTINUE - U(1,L1M1) = UL1M1 -C ......EXIT - IF (LPIVOT .EQ. L1M1) GO TO 140 - KL1 = KL2 - CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) - GO TO 130 - 80 CONTINUE - I2 = 1 - ICV + ICE*(LPIVOT - 1) - INCR = ICE*(L1 - LPIVOT) - DO 120 J = 1, NCV - I2 = I2 + ICV - I3 = I2 + INCR - I4 = I3 - SM = C(I2)*UP - DO 90 I = L1, M - SM = SM + C(I3)*U(1,I) - I3 = I3 + ICE - 90 CONTINUE - IF (SM .EQ. 0.0D0) GO TO 110 - SM = SM*B - C(I2) = C(I2) + SM*UP - DO 100 I = L1, M - C(I4) = C(I4) + SM*U(1,I) - I4 = I4 + ICE - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - 130 CONTINUE - 140 CONTINUE - RETURN - END -*DECK DHFTI - SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, - + G, IP) -C***BEGIN PROLOGUE DHFTI -C***PURPOSE Solve a least squares problem for banded matrices using -C sequential accumulation of rows of the data matrix. -C Exactly one right-hand side vector is permitted. -C***LIBRARY SLATEC -C***CATEGORY D9 -C***TYPE REAL(KIND=R8) (HFTI-S, DHFTI-D) -C***KEYWORDS CURVE FITTING, LEAST SQUARES -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DIMENSION A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N) -C -C This subroutine solves a linear least squares problem or a set of -C linear least squares problems having the same matrix but different -C right-side vectors. The problem data consists of an M by N matrix -C A, an M by NB matrix B, and an absolute tolerance parameter TAU -C whose usage is described below. The NB column vectors of B -C represent right-side vectors for NB distinct linear least squares -C problems. -C -C This set of problems can also be written as the matrix least -C squares problem -C -C AX = B, -C -C where X is the N by NB solution matrix. -C -C Note that if B is the M by M identity matrix, then X will be the -C pseudo-inverse of A. -C -C This subroutine first transforms the augmented matrix (A B) to a -C matrix (R C) using premultiplying Householder transformations with -C column interchanges. All subdiagonal elements in the matrix R are -C zero and its diagonal elements satisfy -C -C ABS(R(I,I)).GE.ABS(R(I+1,I+1)), -C -C I = 1,...,L-1, where -C -C L = MIN(M,N). -C -C The subroutine will compute an integer, KRANK, equal to the number -C of diagonal terms of R that exceed TAU in magnitude. Then a -C solution of minimum Euclidean length is computed using the first -C KRANK rows of (R C). -C -C To be specific we suggest that the user consider an easily -C computable matrix norm, such as, the maximum of all column sums of -C magnitudes. -C -C Now if the relative uncertainty of B is EPS, (norm of uncertainty/ -C norm of B), it is suggested that TAU be set approximately equal to -C EPS*(norm of A). -C -C The user must dimension all arrays appearing in the call list.. -C A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N). This -C permits the solution of a range of problems in the same array -C space. -C -C The entire set of parameters for DHFTI are -C -C INPUT.. All TYPE REAL variables are REAL(KIND=R8) -C -C A(*,*),MDA,M,N The array A(*,*) initially contains the M by N -C matrix A of the least squares problem AX = B. -C The first dimensioning parameter of the array -C A(*,*) is MDA, which must satisfy MDA.GE.M -C Either M.GE.N or M.LT.N is permitted. There -C is no restriction on the rank of A. The -C condition MDA.LT.M is considered an error. -C -C B(*),MDB,NB If NB = 0 the subroutine will perform the -C orthogonal decomposition but will make no -C references to the array B(*). If NB.GT.0 -C the array B(*) must initially contain the M by -C NB matrix B of the least squares problem AX = -C B. If NB.GE.2 the array B(*) must be doubly -C subscripted with first dimensioning parameter -C MDB.GE.MAX(M,N). If NB = 1 the array B(*) may -C be either doubly or singly subscripted. In -C the latter case the value of MDB is arbitrary -C but it should be set to some valid integer -C value such as MDB = M. -C -C The condition of NB.GT.1.AND.MDB.LT. MAX(M,N) -C is considered an error. -C -C TAU Absolute tolerance parameter provided by user -C for pseudorank determination. -C -C H(*),G(*),IP(*) Arrays of working space used by DHFTI. -C -C OUTPUT.. All TYPE REAL variables are REAL(KIND=R8) -C -C A(*,*) The contents of the array A(*,*) will be -C modified by the subroutine. These contents -C are not generally required by the user. -C -C B(*) On return the array B(*) will contain the N by -C NB solution matrix X. -C -C KRANK Set by the subroutine to indicate the -C pseudorank of A. -C -C RNORM(*) On return, RNORM(J) will contain the Euclidean -C norm of the residual vector for the problem -C defined by the J-th column vector of the array -C B(*,*) for J = 1,...,NB. -C -C H(*),G(*) On return these arrays respectively contain -C elements of the pre- and post-multiplying -C Householder transformations used to compute -C the minimum Euclidean length solution. -C -C IP(*) Array in which the subroutine records indices -C describing the permutation of column vectors. -C The contents of arrays H(*),G(*) and IP(*) -C are not generally required by the user. -C -C***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares -C Problems, Prentice-Hall, Inc., 1974, Chapter 14. -C***ROUTINES CALLED D1MACH, DH12, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891006 Cosmetic changes to prologue. (WRB) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 901005 Replace usage of DDIFF with usage of D1MACH. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DHFTI - USE REAL_PRECISION - - INTEGER I, II, IOPT, IP(*), IP1, J, JB, JJ, K, KP1, KRANK, L, - * LDIAG, LMAX, M, MDA, MDB, N, NB, NERR - REAL(KIND=R8) A, B, D1MACH, DZERO, FACTOR, - * G, H, HMAX, RELEPS, RNORM, SM, SM1, SZERO, TAU, TMP - DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*) - SAVE RELEPS - DATA RELEPS /0.D0/ -C BEGIN BLOCK PERMITTING ...EXITS TO 360 -C***FIRST EXECUTABLE STATEMENT DHFTI - IF (RELEPS.EQ.0.D0) RELEPS = D1MACH(4) - SZERO = 0.0D0 - DZERO = 0.0D0 - FACTOR = 0.001D0 -C - K = 0 - LDIAG = MIN(M,N) - IF (LDIAG .LE. 0) GO TO 350 -C BEGIN BLOCK PERMITTING ...EXITS TO 130 -C BEGIN BLOCK PERMITTING ...EXITS TO 120 - IF (MDA .GE. M) GO TO 10 - NERR = 1 - IOPT = 2 -C CALL XERMSG ('SLATEC', 'DHFTI', -C + 'MDA.LT.M, PROBABLE ERROR.', -C + NERR, IOPT) -C ...............EXIT - GO TO 360 - 10 CONTINUE -C - IF (NB .LE. 1 .OR. MAX(M,N) .LE. MDB) GO TO 20 - NERR = 2 - IOPT = 2 -C CALL XERMSG ('SLATEC', 'DHFTI', -C + 'MDB.LT.MAX(M,N).AND.NB.GT.1. PROBABLE ERROR.', -C + NERR, IOPT) -C ...............EXIT - GO TO 360 - 20 CONTINUE -C - DO 100 J = 1, LDIAG -C BEGIN BLOCK PERMITTING ...EXITS TO 70 - IF (J .EQ. 1) GO TO 40 -C -C UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX -C .. - LMAX = J - DO 30 L = J, N - H(L) = H(L) - A(J-1,L)**2 - IF (H(L) .GT. H(LMAX)) LMAX = L - 30 CONTINUE -C ......EXIT - IF (FACTOR*H(LMAX) .GT. HMAX*RELEPS) GO TO 70 - 40 CONTINUE -C -C COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX -C .. - LMAX = J - DO 60 L = J, N - H(L) = 0.0D0 - DO 50 I = J, M - H(L) = H(L) + A(I,L)**2 - 50 CONTINUE - IF (H(L) .GT. H(LMAX)) LMAX = L - 60 CONTINUE - HMAX = H(LMAX) - 70 CONTINUE -C .. -C LMAX HAS BEEN DETERMINED -C -C DO COLUMN INTERCHANGES IF NEEDED. -C .. - IP(J) = LMAX - IF (IP(J) .EQ. J) GO TO 90 - DO 80 I = 1, M - TMP = A(I,J) - A(I,J) = A(I,LMAX) - A(I,LMAX) = TMP - 80 CONTINUE - H(LMAX) = H(J) - 90 CONTINUE -C -C COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A -C AND B. -C .. - CALL DH12(1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA, - * N-J) - CALL DH12(2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB) - 100 CONTINUE -C -C DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, -C TAU. -C .. - DO 110 J = 1, LDIAG -C ......EXIT - IF (ABS(A(J,J)) .LE. TAU) GO TO 120 - 110 CONTINUE - K = LDIAG -C ......EXIT - GO TO 130 - 120 CONTINUE - K = J - 1 - 130 CONTINUE - KP1 = K + 1 -C -C COMPUTE THE NORMS OF THE RESIDUAL VECTORS. -C - IF (NB .LT. 1) GO TO 170 - DO 160 JB = 1, NB - TMP = SZERO - IF (M .LT. KP1) GO TO 150 - DO 140 I = KP1, M - TMP = TMP + B(I,JB)**2 - 140 CONTINUE - 150 CONTINUE - RNORM(JB) = SQRT(TMP) - 160 CONTINUE - 170 CONTINUE -C SPECIAL FOR PSEUDORANK = 0 - IF (K .GT. 0) GO TO 210 - IF (NB .LT. 1) GO TO 200 - DO 190 JB = 1, NB - DO 180 I = 1, N - B(I,JB) = SZERO - 180 CONTINUE - 190 CONTINUE - 200 CONTINUE - GO TO 340 - 210 CONTINUE -C -C IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER -C DECOMPOSITION OF FIRST K ROWS. -C .. - IF (K .EQ. N) GO TO 230 - DO 220 II = 1, K - I = KP1 - II - CALL DH12(1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1) - 220 CONTINUE - 230 CONTINUE -C -C - IF (NB .LT. 1) GO TO 330 - DO 320 JB = 1, NB -C -C SOLVE THE K BY K TRIANGULAR SYSTEM. -C .. - DO 260 L = 1, K - SM = DZERO - I = KP1 - L - IP1 = I + 1 - IF (K .LT. IP1) GO TO 250 - DO 240 J = IP1, K - SM = SM + A(I,J)*B(J,JB) - 240 CONTINUE - 250 CONTINUE - SM1 = SM - B(I,JB) = (B(I,JB) - SM1)/A(I,I) - 260 CONTINUE -C -C COMPLETE COMPUTATION OF SOLUTION VECTOR. -C .. - IF (K .EQ. N) GO TO 290 - DO 270 J = KP1, N - B(J,JB) = SZERO - 270 CONTINUE - DO 280 I = 1, K - CALL DH12(2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1, - * MDB,1) - 280 CONTINUE - 290 CONTINUE -C -C RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE -C COLUMN INTERCHANGES. -C .. - DO 310 JJ = 1, LDIAG - J = LDIAG + 1 - JJ - IF (IP(J) .EQ. J) GO TO 300 - L = IP(J) - TMP = B(L,JB) - B(L,JB) = B(J,JB) - B(J,JB) = TMP - 300 CONTINUE - 310 CONTINUE - 320 CONTINUE - 330 CONTINUE - 340 CONTINUE - 350 CONTINUE -C .. -C THE SOLUTION VECTORS, X, ARE NOW -C IN THE FIRST N ROWS OF THE ARRAY B(,). -C - KRANK = K - 360 CONTINUE - RETURN - END -*DECK DLPDP - SUBROUTINE DLPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, - + IS) -C***BEGIN PROLOGUE DLPDP -C***SUBSIDIARY -C***PURPOSE Subsidiary to DLSEI -C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (LPDP-S, DLPDP-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C **** Double Precision version of LPDP **** -C DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1), -C where N=N1+N2. This is a slight overestimate for WS(*). -C -C Determine an N1-vector W, and -C an N2-vector Z -C which minimizes the Euclidean length of W -C subject to G*W+H*Z .GE. Y. -C This is the least projected distance problem, LPDP. -C The matrices G and H are of respective -C dimensions M by N1 and M by N2. -C -C Called by subprogram DLSI( ). -C -C The matrix -C (G H Y) -C -C occupies rows 1,...,M and cols 1,...,N1+N2+1 of A(*,*). -C -C The solution (W) is returned in X(*). -C (Z) -C -C The value of MODE indicates the status of -C the computation after returning to the user. -C -C MODE=1 The solution was successfully obtained. -C -C MODE=2 The inequalities are inconsistent. -C -C***SEE ALSO DLSEI -C***ROUTINES CALLED DCOPY, DDOT, DNRM2, DSCAL, DWNNLS -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE DLPDP - USE REAL_PRECISION - -C - INTEGER I, IS(*), IW, IX, J, L, M, MDA, MODE, MODEW, N, N1, N2, - * NP1 - REAL(KIND=R8) A(MDA,*), DDOT, DNRM2, FAC, ONE, - * PRGOPT(*), RNORM, SC, WNORM, WS(*), X(*), YNORM, ZERO - SAVE ZERO, ONE, FAC - DATA ZERO,ONE /0.0D0,1.0D0/, FAC /0.1D0/ -C***FIRST EXECUTABLE STATEMENT DLPDP - N = N1 + N2 - MODE = 1 - IF (M .GT. 0) GO TO 20 - IF (N .LE. 0) GO TO 10 - X(1) = ZERO - CALL DCOPY(N,X,0,X,1) - 10 CONTINUE - WNORM = ZERO - GO TO 200 - 20 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 190 - NP1 = N + 1 -C -C SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE. - DO 40 I = 1, M - SC = DNRM2(N,A(I,1),MDA) - IF (SC .EQ. ZERO) GO TO 30 - SC = ONE/SC - CALL DSCAL(NP1,SC,A(I,1),MDA) - 30 CONTINUE - 40 CONTINUE -C -C SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO). - YNORM = DNRM2(M,A(1,NP1),1) - IF (YNORM .EQ. ZERO) GO TO 50 - SC = ONE/YNORM - CALL DSCAL(M,SC,A(1,NP1),1) - 50 CONTINUE -C -C SCALE COLS OF MATRIX H. - J = N1 + 1 - 60 IF (J .GT. N) GO TO 70 - SC = DNRM2(M,A(1,J),1) - IF (SC .NE. ZERO) SC = ONE/SC - CALL DSCAL(M,SC,A(1,J),1) - X(J) = SC - J = J + 1 - GO TO 60 - 70 CONTINUE - IF (N1 .LE. 0) GO TO 130 -C -C COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*). - IW = 0 - DO 80 I = 1, M -C -C MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY. - CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) - IW = IW + N2 -C -C MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY. - CALL DCOPY(N1,A(I,1),MDA,WS(IW+1),1) - IW = IW + N1 -C -C MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY. - WS(IW+1) = A(I,NP1) - IW = IW + 1 - 80 CONTINUE - WS(IW+1) = ZERO - CALL DCOPY(N,WS(IW+1),0,WS(IW+1),1) - IW = IW + N - WS(IW+1) = ONE - IW = IW + 1 -C -C SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0. THE -C MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR -C F = TRANSPOSE OF (0,...,0,1). - IX = IW + 1 - IW = IW + M -C -C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF -C DWNNLS( ). - IS(1) = 0 - IS(2) = 0 - CALL DWNNLS(WS,NP1,N2,NP1-N2,M,0,PRGOPT,WS(IX),RNORM, - * MODEW,IS,WS(IW+1)) -C -C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W. - SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) - IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) - * GO TO 110 - SC = ONE/SC - DO 90 J = 1, N1 - X(J) = SC*DDOT(M,A(1,J),1,WS(IX),1) - 90 CONTINUE -C -C COMPUTE THE VECTOR Q=Y-GW. OVERWRITE Y WITH THIS -C VECTOR. - DO 100 I = 1, M - A(I,NP1) = A(I,NP1) - DDOT(N1,A(I,1),MDA,X,1) - 100 CONTINUE - GO TO 120 - 110 CONTINUE - MODE = 2 -C .........EXIT - GO TO 190 - 120 CONTINUE - 130 CONTINUE - IF (N2 .LE. 0) GO TO 180 -C -C COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*). - IW = 0 - DO 140 I = 1, M - CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) - IW = IW + N2 - WS(IW+1) = A(I,NP1) - IW = IW + 1 - 140 CONTINUE - WS(IW+1) = ZERO - CALL DCOPY(N2,WS(IW+1),0,WS(IW+1),1) - IW = IW + N2 - WS(IW+1) = ONE - IW = IW + 1 - IX = IW + 1 - IW = IW + M -C -C SOLVE RV=S SUBJECT TO V.GE.0. THE MATRIX R =(TRANSPOSE -C OF (H Q)), WHERE Q=Y-GW. THE (N2+1)-VECTOR S =(TRANSPOSE -C OF (0,...,0,1)). -C -C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF -C DWNNLS( ). - IS(1) = 0 - IS(2) = 0 - CALL DWNNLS(WS,N2+1,0,N2+1,M,0,PRGOPT,WS(IX),RNORM,MODEW, - * IS,WS(IW+1)) -C -C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z. - SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) - IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) - * GO TO 160 - SC = ONE/SC - DO 150 J = 1, N2 - L = N1 + J - X(L) = SC*DDOT(M,A(1,L),1,WS(IX),1)*X(L) - 150 CONTINUE - GO TO 170 - 160 CONTINUE - MODE = 2 -C .........EXIT - GO TO 190 - 170 CONTINUE - 180 CONTINUE -C -C ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION. - CALL DSCAL(N,YNORM,X,1) - WNORM = DNRM2(N1,X,1) - 190 CONTINUE - 200 CONTINUE - RETURN - END -*DECK DWNNLS - SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, - + IWORK, WORK) -C***BEGIN PROLOGUE DWNNLS -C***PURPOSE Solve a linearly constrained least squares problem with -C equality constraints and nonnegativity constraints on -C selected variables. -C***LIBRARY SLATEC -C***CATEGORY K1A2A -C***TYPE REAL(KIND=R8) (WNNLS-S, DWNNLS-D) -C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, -C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, -C NONNEGATIVITY CONSTRAINTS, QUADRATIC PROGRAMMING -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Abstract -C -C This subprogram solves a linearly constrained least squares -C problem. Suppose there are given matrices E and A of -C respective dimensions ME by N and MA by N, and vectors F -C and B of respective lengths ME and MA. This subroutine -C solves the problem -C -C EX = F, (equations to be exactly satisfied) -C -C AX = B, (equations to be approximately satisfied, -C in the least squares sense) -C -C subject to components L+1,...,N nonnegative -C -C Any values ME.GE.0, MA.GE.0 and 0.LE. L .LE.N are permitted. -C -C The problem is reposed as problem DWNNLS -C -C (WT*E)X = (WT*F) -C ( A) ( B), (least squares) -C subject to components L+1,...,N nonnegative. -C -C The subprogram chooses the heavy weight (or penalty parameter) WT. -C -C The parameters for DWNNLS are -C -C INPUT.. All TYPE REAL variables are REAL(KIND=R8) -C -C W(*,*),MDW, The array W(*,*) is double subscripted with first -C ME,MA,N,L dimensioning parameter equal to MDW. For this -C discussion let us call M = ME + MA. Then MDW -C must satisfy MDW.GE.M. The condition MDW.LT.M -C is an error. -C -C The array W(*,*) contains the matrices and vectors -C -C (E F) -C (A B) -C -C in rows and columns 1,...,M and 1,...,N+1 -C respectively. Columns 1,...,L correspond to -C unconstrained variables X(1),...,X(L). The -C remaining variables are constrained to be -C nonnegative. The condition L.LT.0 or L.GT.N is -C an error. -C -C PRGOPT(*) This double precision array is the option vector. -C If the user is satisfied with the nominal -C subprogram features set -C -C PRGOPT(1)=1 (or PRGOPT(1)=1.0) -C -C Otherwise PRGOPT(*) is a linked list consisting of -C groups of data of the following form -C -C LINK -C KEY -C DATA SET -C -C The parameters LINK and KEY are each one word. -C The DATA SET can be comprised of several words. -C The number of items depends on the value of KEY. -C The value of LINK points to the first -C entry of the next group of data within -C PRGOPT(*). The exception is when there are -C no more options to change. In that -C case LINK=1 and the values KEY and DATA SET -C are not referenced. The general layout of -C PRGOPT(*) is as follows. -C -C ...PRGOPT(1)=LINK1 (link to first entry of next group) -C . PRGOPT(2)=KEY1 (key to the option change) -C . PRGOPT(3)=DATA VALUE (data value for this change) -C . . -C . . -C . . -C ...PRGOPT(LINK1)=LINK2 (link to the first entry of -C . next group) -C . PRGOPT(LINK1+1)=KEY2 (key to the option change) -C . PRGOPT(LINK1+2)=DATA VALUE -C ... . -C . . -C . . -C ...PRGOPT(LINK)=1 (no more options to change) -C -C Values of LINK that are nonpositive are errors. -C A value of LINK.GT.NLINK=100000 is also an error. -C This helps prevent using invalid but positive -C values of LINK that will probably extend -C beyond the program limits of PRGOPT(*). -C Unrecognized values of KEY are ignored. The -C order of the options is arbitrary and any number -C of options can be changed with the following -C restriction. To prevent cycling in the -C processing of the option array a count of the -C number of options changed is maintained. -C Whenever this count exceeds NOPT=1000 an error -C message is printed and the subprogram returns. -C -C OPTIONS.. -C -C KEY=6 -C Scale the nonzero columns of the -C entire data matrix -C (E) -C (A) -C to have length one. The DATA SET for -C this option is a single value. It must -C be nonzero if unit length column scaling is -C desired. -C -C KEY=7 -C Scale columns of the entire data matrix -C (E) -C (A) -C with a user-provided diagonal matrix. -C The DATA SET for this option consists -C of the N diagonal scaling factors, one for -C each matrix column. -C -C KEY=8 -C Change the rank determination tolerance from -C the nominal value of SQRT(SRELPR). This quantity -C can be no smaller than SRELPR, The arithmetic- -C storage precision. The quantity used -C here is internally restricted to be at -C least SRELPR. The DATA SET for this option -C is the new tolerance. -C -C KEY=9 -C Change the blow-up parameter from the -C nominal value of SQRT(SRELPR). The reciprocal of -C this parameter is used in rejecting solution -C components as too large when a variable is -C first brought into the active set. Too large -C means that the proposed component times the -C reciprocal of the parameter is not less than -C the ratio of the norms of the right-side -C vector and the data matrix. -C This parameter can be no smaller than SRELPR, -C the arithmetic-storage precision. -C -C For example, suppose we want to provide -C a diagonal matrix to scale the problem -C matrix and change the tolerance used for -C determining linear dependence of dropped col -C vectors. For these options the dimensions of -C PRGOPT(*) must be at least N+6. The FORTRAN -C statements defining these options would -C be as follows. -C -C PRGOPT(1)=N+3 (link to entry N+3 in PRGOPT(*)) -C PRGOPT(2)=7 (user-provided scaling key) -C -C CALL DCOPY(N,D,1,PRGOPT(3),1) (copy the N -C scaling factors from a user array called D(*) -C into PRGOPT(3)-PRGOPT(N+2)) -C -C PRGOPT(N+3)=N+6 (link to entry N+6 of PRGOPT(*)) -C PRGOPT(N+4)=8 (linear dependence tolerance key) -C PRGOPT(N+5)=... (new value of the tolerance) -C -C PRGOPT(N+6)=1 (no more options to change) -C -C -C IWORK(1), The amounts of working storage actually allocated -C IWORK(2) for the working arrays WORK(*) and IWORK(*), -C respectively. These quantities are compared with -C the actual amounts of storage needed for DWNNLS( ). -C Insufficient storage allocated for either WORK(*) -C or IWORK(*) is considered an error. This feature -C was included in DWNNLS( ) because miscalculating -C the storage formulas for WORK(*) and IWORK(*) -C might very well lead to subtle and hard-to-find -C execution errors. -C -C The length of WORK(*) must be at least -C -C LW = ME+MA+5*N -C This test will not be made if IWORK(1).LE.0. -C -C The length of IWORK(*) must be at least -C -C LIW = ME+MA+N -C This test will not be made if IWORK(2).LE.0. -C -C OUTPUT.. All TYPE REAL variables are REAL(KIND=R8) -C -C X(*) An array dimensioned at least N, which will -C contain the N components of the solution vector -C on output. -C -C RNORM The residual norm of the solution. The value of -C RNORM contains the residual vector length of the -C equality constraints and least squares equations. -C -C MODE The value of MODE indicates the success or failure -C of the subprogram. -C -C MODE = 0 Subprogram completed successfully. -C -C = 1 Max. number of iterations (equal to -C 3*(N-L)) exceeded. Nearly all problems -C should complete in fewer than this -C number of iterations. An approximate -C solution and its corresponding residual -C vector length are in X(*) and RNORM. -C -C = 2 Usage error occurred. The offending -C condition is noted with the error -C processing subprogram, XERMSG( ). -C -C User-designated -C Working arrays.. -C -C WORK(*) A double precision working array of length at least -C M + 5*N. -C -C IWORK(*) An integer-valued working array of length at least -C M+N. -C -C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Report SAND77-0552, Sandia -C Laboratories, June 1978. -C K. H. Haskell and R. J. Hanson, Selected algorithms for -C the linearly constrained least squares problem - a -C users guide, Report SAND78-1290, Sandia Laboratories, -C August 1979. -C K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Mathematical Programming -C 21 (1981), pp. 98-118. -C R. J. Hanson and K. H. Haskell, Two algorithms for the -C linearly constrained least squares problem, ACM -C Transactions on Mathematical Software, September 1982. -C C. L. Lawson and R. J. Hanson, Solving Least Squares -C Problems, Prentice-Hall, Inc., 1974. -C***ROUTINES CALLED DWNLSM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls, change Prologue -C comments to agree with WNNLS. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Removed prints and replaced DP --> REAL(KIND=R8). (THC) -C***END PROLOGUE DWNNLS - USE REAL_PRECISION - - INTEGER IWORK(*), L, L1, L2, L3, L4, L5, LIW, LW, MA, MDW, ME, - * MODE, N - REAL(KIND=R8) PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) -C CHARACTER*8 XERN1 -C***FIRST EXECUTABLE STATEMENT DWNNLS - MODE = 0 - IF (MA+ME.LE.0 .OR. N.LE.0) RETURN -C - IF (IWORK(1).GT.0) THEN - LW = ME + MA + 5*N - IF (IWORK(1).LT.LW) THEN -C WRITE (XERN1, '(I8)') LW -C CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // -C * 'ALLOCATED FOR WORK(*), NEED LW = ' // XERN1, 2, 1) - MODE = 2 - RETURN - ENDIF - ENDIF -C - IF (IWORK(2).GT.0) THEN - LIW = ME + MA + N - IF (IWORK(2).LT.LIW) THEN -C WRITE (XERN1, '(I8)') LIW -C CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // -C * 'ALLOCATED FOR IWORK(*), NEED LIW = ' // XERN1, 2, 1) - MODE = 2 - RETURN - ENDIF - ENDIF -C - IF (MDW.LT.ME+MA) THEN -C CALL XERMSG ('SLATEC', 'DWNNLS', -C * 'THE VALUE MDW.LT.ME+MA IS AN ERROR', 1, 1) - MODE = 2 - RETURN - ENDIF -C - IF (L.LT.0 .OR. L.GT.N) THEN -C CALL XERMSG ('SLATEC', 'DWNNLS', -C * 'L.GE.0 .AND. L.LE.N IS REQUIRED', 2, 1) - MODE = 2 - RETURN - ENDIF -C -C THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS -C WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS -C REQUIRED BY THE MAIN SUBROUTINE DWNLSM( ). -C - L1 = N + 1 - L2 = L1 + N - L3 = L2 + ME + MA - L4 = L3 + N - L5 = L4 + N -C - CALL DWNLSM(W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, IWORK, - * IWORK(L1), WORK(1), WORK(L1), WORK(L2), WORK(L3), - * WORK(L4), WORK(L5)) - RETURN - END -*DECK DWNLSM - SUBROUTINE DWNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, - + IPIVOT, ITYPE, WD, H, SCALE, Z, TEMP, D) -C***BEGIN PROLOGUE DWNLSM -C***SUBSIDIARY -C***PURPOSE Subsidiary to DWNNLS -C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (WNLSM-S, DWNLSM-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to DWNNLS. -C The documentation for DWNNLS has complete usage instructions. -C -C In addition to the parameters discussed in the prologue to -C subroutine DWNNLS, the following work arrays are used in -C subroutine DWNLSM (they are passed through the calling -C sequence from DWNNLS for purposes of variable dimensioning). -C Their contents will in general be of no interest to the user. -C -C Variables of type REAL are REAL(KIND=R8). -C -C IPIVOT(*) -C An array of length N. Upon completion it contains the -C pivoting information for the cols of W(*,*). -C -C ITYPE(*) -C An array of length M which is used to keep track -C of the classification of the equations. ITYPE(I)=0 -C denotes equation I as an equality constraint. -C ITYPE(I)=1 denotes equation I as a least squares -C equation. -C -C WD(*) -C An array of length N. Upon completion it contains the -C dual solution vector. -C -C H(*) -C An array of length N. Upon completion it contains the -C pivot scalars of the Householder transformations performed -C in the case KRANK.LT.L. -C -C SCALE(*) -C An array of length M which is used by the subroutine -C to store the diagonal matrix of weights. -C These are used to apply the modified Givens -C transformations. -C -C Z(*),TEMP(*) -C Working arrays of length N. -C -C D(*) -C An array of length N that contains the -C column scaling for the matrix (E). -C (A) -C -C***SEE ALSO DWNNLS -C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, -C SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, -C DWNLIT, IDAMAX, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Fixed an error message. (RWC) -C 900604 DP version created from SP version. (RWC) -C 900911 Restriction on value of ALAMDA included. (WRB) -C***END PROLOGUE DWNLSM - USE REAL_PRECISION - - INTEGER IPIVOT(*), ITYPE(*), L, MA, MDW, MME, MODE, N - REAL(KIND=R8) D(*), H(*), PRGOPT(*), RNORM, SCALE(*), TEMP(*), - * W(MDW,*), WD(*), X(*), Z(*) -C - EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, SLATEC_DROTM, - * SLATEC_DROTMG, DSCAL, DSWAP, DWNLIT, IDAMAX, XERMSG - REAL(KIND=R8) D1MACH, DASUM, DNRM2 - INTEGER IDAMAX -C - REAL(KIND=R8) ALAMDA, ALPHA, ALSQ, AMAX, BLOWUP, BNORM, - * DOPE(3), DRELPR, EANORM, FAC, SM, SPARAM(5), T, TAU, WMAX, Z2, - * ZZ - INTEGER I, IDOPE(3), IMAX, ISOL, ITEMP, ITER, ITMAX, IWMAX, J, - * JCON, JP, KEY, KRANK, L1, LAST, LINK, M, ME, NEXT, NIV, NLINK, - * NOPT, NSOLN, NTIMES - LOGICAL DONE, FEASBL, FIRST, HITCON, POS -C - SAVE DRELPR, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DWNLSM -C -C Initialize variables. -C DRELPR is the precision for the particular machine -C being used. This logic avoids resetting it every entry. -C - IF (FIRST) DRELPR = D1MACH(4) - FIRST = .FALSE. -C -C Set the nominal tolerance used in the code. -C - TAU = SQRT(DRELPR) -C - M = MA + MME - ME = MME - MODE = 2 -C -C To process option vector -C - FAC = 1.D-4 -C -C Set the nominal blow up factor used in the code. -C - BLOWUP = TAU -C -C The nominal column scaling used in the code is -C the identity scaling. -C - CALL DCOPY (N, 1.D0, 0, D, 1) -C -C Define bound for number of options to change. -C - NOPT = 1000 -C -C Define bound for positive value of LINK. -C - NLINK = 100000 - NTIMES = 0 - LAST = 1 - LINK = PRGOPT(1) - IF (LINK.LE.0 .OR. LINK.GT.NLINK) THEN -C CALL XERMSG ('SLATEC', 'DWNLSM', -C + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) - RETURN - ENDIF -C - 100 IF (LINK.GT.1) THEN - NTIMES = NTIMES + 1 - IF (NTIMES.GT.NOPT) THEN -C CALL XERMSG ('SLATEC', 'DWNLSM', -C + 'IN DWNNLS, THE LINKS IN THE OPTION VECTOR ARE CYCLING.', -C + 3, 1) - RETURN - ENDIF -C - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.6 .AND. PRGOPT(LAST+2).NE.0.D0) THEN - DO 110 J = 1,N - T = DNRM2(M,W(1,J),1) - IF (T.NE.0.D0) T = 1.D0/T - D(J) = T - 110 CONTINUE - ENDIF -C - IF (KEY.EQ.7) CALL DCOPY (N, PRGOPT(LAST+2), 1, D, 1) - IF (KEY.EQ.8) TAU = MAX(DRELPR,PRGOPT(LAST+2)) - IF (KEY.EQ.9) BLOWUP = MAX(DRELPR,PRGOPT(LAST+2)) -C - NEXT = PRGOPT(LINK) - IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN -C CALL XERMSG ('SLATEC', 'DWNLSM', -C + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) - RETURN - ENDIF -C - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C - DO 120 J = 1,N - CALL DSCAL (M, D(J), W(1,J), 1) - 120 CONTINUE -C -C Process option vector -C - DONE = .FALSE. - ITER = 0 - ITMAX = 3*(N-L) - MODE = 0 - NSOLN = L - L1 = MIN(M,L) -C -C Compute scale factor to apply to equality constraint equations. -C - DO 130 J = 1,N - WD(J) = DASUM(M,W(1,J),1) - 130 CONTINUE -C - IMAX = IDAMAX(N,WD,1) - EANORM = WD(IMAX) - BNORM = DASUM(M,W(1,N+1),1) - ALAMDA = EANORM/(DRELPR*FAC) -C -C On machines, such as the VAXes using D floating, with a very -C limited exponent range for double precision values, the previously -C computed value of ALAMDA may cause an overflow condition. -C Therefore, this code further limits the value of ALAMDA. -C - ALAMDA = MIN(ALAMDA,SQRT(D1MACH(2))) -C -C Define scaling diagonal matrix for modified Givens usage and -C classify equation types. -C - ALSQ = ALAMDA**2 - DO 140 I = 1,M -C -C When equation I is heavily weighted ITYPE(I)=0, -C else ITYPE(I)=1. -C - IF (I.LE.ME) THEN - T = ALSQ - ITEMP = 0 - ELSE - T = 1.D0 - ITEMP = 1 - ENDIF - SCALE(I) = T - ITYPE(I) = ITEMP - 140 CONTINUE -C -C Set the solution vector X(*) to zero and the column interchange -C matrix to the identity. -C - CALL DCOPY (N, 0.D0, 0, X, 1) - DO 150 I = 1,N - IPIVOT(I) = I - 150 CONTINUE -C -C Perform initial triangularization in the submatrix -C corresponding to the unconstrained variables. -C Set first L components of dual vector to zero because -C these correspond to the unconstrained variables. -C - CALL DCOPY (L, 0.D0, 0, WD, 1) -C -C The arrays IDOPE(*) and DOPE(*) are used to pass -C information to DWNLIT(). This was done to avoid -C a long calling sequence or the use of COMMON. -C - IDOPE(1) = ME - IDOPE(2) = NSOLN - IDOPE(3) = L1 -C - DOPE(1) = ALSQ - DOPE(2) = EANORM - DOPE(3) = TAU - CALL DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM, - + IDOPE, DOPE, DONE) - ME = IDOPE(1) - KRANK = IDOPE(2) - NIV = IDOPE(3) -C -C Perform WNNLS algorithm using the following steps. -C -C Until(DONE) -C compute search direction and feasible point -C when (HITCON) add constraints -C else perform multiplier test and drop a constraint -C fin -C Compute-Final-Solution -C -C To compute search direction and feasible point, -C solve the triangular system of currently non-active -C variables and store the solution in Z(*). -C -C To solve system -C Copy right hand side into TEMP vector to use overwriting method. -C - 160 IF (DONE) GO TO 330 - ISOL = L + 1 - IF (NSOLN.GE.ISOL) THEN - CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) - DO 170 J = NSOLN,ISOL,-1 - IF (J.GT.KRANK) THEN - I = NIV - NSOLN + J - ELSE - I = J - ENDIF -C - IF (J.GT.KRANK .AND. J.LE.L) THEN - Z(J) = 0.D0 - ELSE - Z(J) = TEMP(I)/W(I,J) - CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) - ENDIF - 170 CONTINUE - ENDIF -C -C Increment iteration counter and check against maximum number -C of iterations. -C - ITER = ITER + 1 - IF (ITER.GT.ITMAX) THEN - MODE = 1 - DONE = .TRUE. - ENDIF -C -C Check to see if any constraints have become active. -C If so, calculate an interpolation factor so that all -C active constraints are removed from the basis. -C - ALPHA = 2.D0 - HITCON = .FALSE. - DO 180 J = L+1,NSOLN - ZZ = Z(J) - IF (ZZ.LE.0.D0) THEN - T = X(J)/(X(J)-ZZ) - IF (T.LT.ALPHA) THEN - ALPHA = T - JCON = J - ENDIF - HITCON = .TRUE. - ENDIF - 180 CONTINUE -C -C Compute search direction and feasible point -C - IF (HITCON) THEN -C -C To add constraints, use computed ALPHA to interpolate between -C last feasible solution X(*) and current unconstrained (and -C infeasible) solution Z(*). -C - DO 190 J = L+1,NSOLN - X(J) = X(J) + ALPHA*(Z(J)-X(J)) - 190 CONTINUE - FEASBL = .FALSE. -C -C Remove column JCON and shift columns JCON+1 through N to the -C left. Swap column JCON into the N th position. This achieves -C upper Hessenberg form for the nonactive constraints and -C leaves an upper Hessenberg matrix to retriangularize. -C - 200 DO 210 I = 1,M - T = W(I,JCON) - CALL DCOPY (N-JCON, W(I, JCON+1), MDW, W(I, JCON), MDW) - W(I,N) = T - 210 CONTINUE -C -C Update permuted index vector to reflect this shift and swap. -C - ITEMP = IPIVOT(JCON) - DO 220 I = JCON,N - 1 - IPIVOT(I) = IPIVOT(I+1) - 220 CONTINUE - IPIVOT(N) = ITEMP -C -C Similarly permute X(*) vector. -C - CALL DCOPY (N-JCON, X(JCON+1), 1, X(JCON), 1) - X(N) = 0.D0 - NSOLN = NSOLN - 1 - NIV = NIV - 1 -C -C Retriangularize upper Hessenberg matrix after adding -C constraints. -C - I = KRANK + JCON - L - DO 230 J = JCON,NSOLN - IF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.0) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), - + MDW, SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.1) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), - + MDW, SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.0) THEN - CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) - CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) - ITEMP = ITYPE(I+1) - ITYPE(I+1) = ITYPE(I) - ITYPE(I) = ITEMP -C -C Swapped row was formerly a pivot element, so it will -C be large enough to perform elimination. -C Zero IP1 to I in column J. -C - IF (W(I+1,J).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), - + MDW, SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.1) THEN - IF (SCALE(I)*W(I,J)**2/ALSQ.GT.(TAU*EANORM)**2) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, - + W(I+1,J+1), MDW, SPARAM) - ENDIF - ELSE - CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) - CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) - ITEMP = ITYPE(I+1) - ITYPE(I+1) = ITYPE(I) - ITYPE(I) = ITEMP - W(I+1,J) = 0.D0 - ENDIF - ENDIF - I = I + 1 - 230 CONTINUE -C -C See if the remaining coefficients in the solution set are -C feasible. They should be because of the way ALPHA was -C determined. If any are infeasible, it is due to roundoff -C error. Any that are non-positive will be set to zero and -C removed from the solution set. -C - DO 240 JCON = L+1,NSOLN - IF (X(JCON).LE.0.D0) GO TO 250 - 240 CONTINUE - FEASBL = .TRUE. - 250 IF (.NOT.FEASBL) GO TO 200 - ELSE -C -C To perform multiplier test and drop a constraint. -C - CALL DCOPY (NSOLN, Z, 1, X, 1) - IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) -C -C Reclassify least squares equations as equalities as necessary. -C - I = NIV + 1 - 260 IF (I.LE.ME) THEN - IF (ITYPE(I).EQ.0) THEN - I = I + 1 - ELSE - CALL DSWAP (N+1, W(I,1), MDW, W(ME,1), MDW) - CALL DSWAP (1, SCALE(I), 1, SCALE(ME), 1) - ITEMP = ITYPE(I) - ITYPE(I) = ITYPE(ME) - ITYPE(ME) = ITEMP - ME = ME - 1 - ENDIF - GO TO 260 - ENDIF -C -C Form inner product vector WD(*) of dual coefficients. -C - DO 280 J = NSOLN+1,N - SM = 0.D0 - DO 270 I = NSOLN+1,M - SM = SM + SCALE(I)*W(I,J)*W(I,N+1) - 270 CONTINUE - WD(J) = SM - 280 CONTINUE -C -C Find J such that WD(J)=WMAX is maximum. This determines -C that the incoming column J will reduce the residual vector -C and be positive. -C - 290 WMAX = 0.D0 - IWMAX = NSOLN + 1 - DO 300 J = NSOLN+1,N - IF (WD(J).GT.WMAX) THEN - WMAX = WD(J) - IWMAX = J - ENDIF - 300 CONTINUE - IF (WMAX.LE.0.D0) GO TO 330 -C -C Set dual coefficients to zero for incoming column. -C - WD(IWMAX) = 0.D0 -C -C WMAX .GT. 0.D0, so okay to move column IWMAX to solution set. -C Perform transformation to retriangularize, and test for near -C linear dependence. -C -C Swap column IWMAX into NSOLN-th position to maintain upper -C Hessenberg form of adjacent columns, and add new column to -C triangular decomposition. -C - NSOLN = NSOLN + 1 - NIV = NIV + 1 - IF (NSOLN.NE.IWMAX) THEN - CALL DSWAP (M, W(1,NSOLN), 1, W(1,IWMAX), 1) - WD(IWMAX) = WD(NSOLN) - WD(NSOLN) = 0.D0 - ITEMP = IPIVOT(NSOLN) - IPIVOT(NSOLN) = IPIVOT(IWMAX) - IPIVOT(IWMAX) = ITEMP - ENDIF -C -C Reduce column NSOLN so that the matrix of nonactive constraints -C variables is triangular. -C - DO 320 J = M,NIV+1,-1 - JP = J - 1 -C -C When operating near the ME line, test to see if the pivot -C element is near zero. If so, use the largest element above -C it as the pivot. This is to maintain the sharp interface -C between weighted and non-weighted rows in all cases. -C - IF (J.EQ.ME+1) THEN - IMAX = ME - AMAX = SCALE(ME)*W(ME,NSOLN)**2 - DO 310 JP = J - 1,NIV,-1 - T = SCALE(JP)*W(JP,NSOLN)**2 - IF (T.GT.AMAX) THEN - IMAX = JP - AMAX = T - ENDIF - 310 CONTINUE - JP = IMAX - ENDIF -C - IF (W(J,NSOLN).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(JP), SCALE(J), W(JP,NSOLN), - + W(J,NSOLN), SPARAM) - W(J,NSOLN) = 0.D0 - CALL SLATEC_DROTM (N+1-NSOLN, W(JP,NSOLN+1), MDW, - + W(J,NSOLN+1), MDW, SPARAM) - ENDIF - 320 CONTINUE -C -C Solve for Z(NSOLN)=proposed new value for X(NSOLN). Test if -C this is nonpositive or too large. If this was true or if the -C pivot term was zero, reject the column as dependent. -C - IF (W(NIV,NSOLN).NE.0.D0) THEN - ISOL = NIV - Z2 = W(ISOL,N+1)/W(ISOL,NSOLN) - Z(NSOLN) = Z2 - POS = Z2 .GT. 0.D0 - IF (Z2*EANORM.GE.BNORM .AND. POS) THEN - POS = .NOT. (BLOWUP*Z2*EANORM.GE.BNORM) - ENDIF -C -C Try to add row ME+1 as an additional equality constraint. -C Check size of proposed new solution component. -C Reject it if it is too large. -C - ELSEIF (NIV.LE.ME .AND. W(ME+1,NSOLN).NE.0.D0) THEN - ISOL = ME + 1 - IF (POS) THEN -C -C Swap rows ME+1 and NIV, and scale factors for these rows. -C - CALL DSWAP (N+1, W(ME+1,1), MDW, W(NIV,1), MDW) - CALL DSWAP (1, SCALE(ME+1), 1, SCALE(NIV), 1) - ITEMP = ITYPE(ME+1) - ITYPE(ME+1) = ITYPE(NIV) - ITYPE(NIV) = ITEMP - ME = ME + 1 - ENDIF - ELSE - POS = .FALSE. - ENDIF -C - IF (.NOT.POS) THEN - NSOLN = NSOLN - 1 - NIV = NIV - 1 - ENDIF - IF (.NOT.(POS.OR.DONE)) GO TO 290 - ENDIF - GO TO 160 -C -C Else perform multiplier test and drop a constraint. To compute -C final solution. Solve system, store results in X(*). -C -C Copy right hand side into TEMP vector to use overwriting method. -C - 330 ISOL = 1 - IF (NSOLN.GE.ISOL) THEN - CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) - DO 340 J = NSOLN,ISOL,-1 - IF (J.GT.KRANK) THEN - I = NIV - NSOLN + J - ELSE - I = J - ENDIF -C - IF (J.GT.KRANK .AND. J.LE.L) THEN - Z(J) = 0.D0 - ELSE - Z(J) = TEMP(I)/W(I,J) - CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) - ENDIF - 340 CONTINUE - ENDIF -C -C Solve system. -C - CALL DCOPY (NSOLN, Z, 1, X, 1) -C -C Apply Householder transformations to X(*) if KRANK.LT.L -C - IF (KRANK.LT.L) THEN - DO 350 I = 1,KRANK - CALL DH12 (2, I, KRANK+1, L, W(I,1), MDW, H(I), X, 1, 1, 1) - 350 CONTINUE - ENDIF -C -C Fill in trailing zeroes for constrained variables not in solution. -C - IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) -C -C Permute solution vector to natural order. -C - DO 380 I = 1,N - J = I - 360 IF (IPIVOT(J).EQ.I) GO TO 370 - J = J + 1 - GO TO 360 -C - 370 IPIVOT(J) = IPIVOT(I) - IPIVOT(I) = J - CALL DSWAP (1, X(J), 1, X(I), 1) - 380 CONTINUE -C -C Rescale the solution using the column scaling. -C - DO 390 J = 1,N - X(J) = X(J)*D(J) - 390 CONTINUE -C - DO 400 I = NSOLN+1,M - T = W(I,N+1) - IF (I.LE.ME) T = T/ALAMDA - T = (SCALE(I)*T)*T - RNORM = RNORM + T - 400 CONTINUE -C - RNORM = SQRT(RNORM) - RETURN - END -*DECK DROTM - SUBROUTINE SLATEC_DROTM (N, DX, INCX, DY, INCY, DPARAM) -C***BEGIN PROLOGUE SLATEC_DROTM -C***PURPOSE Apply a modified Givens transformation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A8 -C***TYPE REAL(KIND=R8) (SROTM-S, DROTM-D) -C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C Kincaid, D. R., (U. of Texas) -C Krogh, F. T., (JPL) -C***DESCRIPTION -C -C B L A S Subprogram -C Description of Parameters -C -C --Input-- -C N number of elements in input vector(s) -C DX double precision vector with N elements -C INCX storage spacing between elements of DX -C DY double precision vector with N elements -C INCY storage spacing between elements of DY -C DPARAM 5-element D.P. vector. DPARAM(1) is DFLAG described below. -C Locations 2-5 of SPARAM contain elements of the -C transformation matrix H described below. -C -C --Output-- -C DX rotated vector (unchanged if N .LE. 0) -C DY rotated vector (unchanged if N .LE. 0) -C -C Apply the modified Givens transformation, H, to the 2 by N matrix -C (DX**T) -C (DY**T) , where **T indicates transpose. The elements of DX are -C in DX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else -C LX = 1+(1-N)*INCX, and similarly for DY using LY and INCY. -C -C With DPARAM(1)=DFLAG, H has one of the following forms: -C -C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 -C -C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) -C H=( ) ( ) ( ) ( ) -C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). -C -C See SLATEC_DROTMG for a description of data storage in DPARAM. -C -C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. -C Krogh, Basic linear algebra subprograms for Fortran -C usage, Algorithm No. 539, Transactions on Mathematical -C Software 5, 3 (September 1979), pp. 308-323. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920310 Corrected definition of LX in DESCRIPTION. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Renamed SLATEC_DROTM to avoid BLAS naming conflict. (THC) -C***END PROLOGUE SLATEC_DROTM - USE REAL_PRECISION - - REAL(KIND=R8) DFLAG, DH12, DH22, DX, TWO, Z, DH11, DH21, - 1 DPARAM, DY, W, ZERO - DIMENSION DX(*), DY(*), DPARAM(5) - SAVE ZERO, TWO - DATA ZERO, TWO /0.0D0, 2.0D0/ -C***FIRST EXECUTABLE STATEMENT SLATEC_DROTM - DFLAG=DPARAM(1) - IF (N.LE.0 .OR. (DFLAG+TWO.EQ.ZERO)) GO TO 140 - IF (.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 -C - NSTEPS=N*INCX -C IF (DFLAG) 50, 10, 30 -C Replaced obsolete code above with an IF-block (THC). - IF (DFLAG < 0) THEN - GO TO 50 - ELSE IF (DFLAG == 0) THEN - GO TO 10 - ELSE IF (DFLAG > 0) THEN - GO TO 30 - END IF - 10 CONTINUE - DH12=DPARAM(4) - DH21=DPARAM(3) - DO 20 I = 1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W+Z*DH12 - DY(I)=W*DH21+Z - 20 CONTINUE - GO TO 140 - 30 CONTINUE - DH11=DPARAM(2) - DH22=DPARAM(5) - DO 40 I = 1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W*DH11+Z - DY(I)=-W+DH22*Z - 40 CONTINUE - GO TO 140 - 50 CONTINUE - DH11=DPARAM(2) - DH12=DPARAM(4) - DH21=DPARAM(3) - DH22=DPARAM(5) - DO 60 I = 1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W*DH11+Z*DH12 - DY(I)=W*DH21+Z*DH22 - 60 CONTINUE - GO TO 140 - 70 CONTINUE - KX=1 - KY=1 - IF (INCX .LT. 0) KX = 1+(1-N)*INCX - IF (INCY .LT. 0) KY = 1+(1-N)*INCY -C -C IF (DFLAG) 120,80,100 -C Replaced obsolete code above with an IF-block (THC). - IF (DFLAG < 0) THEN - GO TO 120 - ELSE IF (DFLAG == 0) THEN - GO TO 80 - ELSE IF (DFLAG > 0) THEN - GO TO 100 - END IF - 80 CONTINUE - DH12=DPARAM(4) - DH21=DPARAM(3) - DO 90 I = 1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W+Z*DH12 - DY(KY)=W*DH21+Z - KX=KX+INCX - KY=KY+INCY - 90 CONTINUE - GO TO 140 - 100 CONTINUE - DH11=DPARAM(2) - DH22=DPARAM(5) - DO 110 I = 1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W*DH11+Z - DY(KY)=-W+DH22*Z - KX=KX+INCX - KY=KY+INCY - 110 CONTINUE - GO TO 140 - 120 CONTINUE - DH11=DPARAM(2) - DH12=DPARAM(4) - DH21=DPARAM(3) - DH22=DPARAM(5) - DO 130 I = 1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W*DH11+Z*DH12 - DY(KY)=W*DH21+Z*DH22 - KX=KX+INCX - KY=KY+INCY - 130 CONTINUE - 140 CONTINUE - RETURN - END -*DECK SLATEC_DROTMG - SUBROUTINE SLATEC_DROTMG (DD1, DD2, DX1, DY1, DPARAM) -C***BEGIN PROLOGUE SLATEC_DROTMG -C***PURPOSE Construct a modified Givens transformation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B10 -C***TYPE REAL(KIND=R8) (SROTMG-S, DROTMG-D) -C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C Kincaid, D. R., (U. of Texas) -C Krogh, F. T., (JPL) -C***DESCRIPTION -C -C B L A S Subprogram -C Description of Parameters -C -C --Input-- -C DD1 double precision scalar -C DD2 double precision scalar -C DX1 double precision scalar -C DX2 double precision scalar -C DPARAM D.P. 5-vector. DPARAM(1)=DFLAG defined below. -C Locations 2-5 contain the rotation matrix. -C -C --Output-- -C DD1 changed to represent the effect of the transformation -C DD2 changed to represent the effect of the transformation -C DX1 changed to represent the effect of the transformation -C DX2 unchanged -C -C Construct the modified Givens transformation matrix H which zeros -C the second component of the 2-vector (SQRT(DD1)*DX1,SQRT(DD2)* -C DY2)**T. -C With DPARAM(1)=DFLAG, H has one of the following forms: -C -C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 -C -C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) -C H=( ) ( ) ( ) ( ) -C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). -C -C Locations 2-5 of DPARAM contain DH11, DH21, DH12, and DH22, -C respectively. (Values of 1.D0, -1.D0, or 0.D0 implied by the -C value of DPARAM(1) are not stored in DPARAM.) -C -C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. -C Krogh, Basic linear algebra subprograms for Fortran -C usage, Algorithm No. 539, Transactions on Mathematical -C Software 5, 3 (September 1979), pp. 308-323. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920316 Prologue corrected. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 180613 Renamed SLATEC_DROTMG to avoid BLAS naming conflict. (THC) -C***END PROLOGUE SLATEC_DROTMG - USE REAL_PRECISION - - REAL(KIND=R8) GAM, ONE, RGAMSQ, DD1, DD2, DH11, DH12, DH21, - 1 DH22, DPARAM, DP1, DP2, DQ1, DQ2, DU, DY1, ZERO, - 2 GAMSQ, DFLAG, DTEMP, DX1, TWO - DIMENSION DPARAM(5) - SAVE ZERO, ONE, TWO, GAM, GAMSQ, RGAMSQ - DATA ZERO, ONE, TWO /0.0D0, 1.0D0, 2.0D0/ - DATA GAM, GAMSQ, RGAMSQ /4096.0D0, 16777216.D0, 5.9604645D-8/ -C***FIRST EXECUTABLE STATEMENT SLATEC_DROTMG - IF (.NOT. DD1 .LT. ZERO) GO TO 10 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 10 CONTINUE -C CASE-DD1-NONNEGATIVE - DP2=DD2*DY1 - IF (.NOT. DP2 .EQ. ZERO) GO TO 20 - DFLAG=-TWO - GO TO 260 -C REGULAR-CASE.. - 20 CONTINUE - DP1=DD1*DX1 - DQ2=DP2*DY1 - DQ1=DP1*DX1 -C - IF (.NOT. ABS(DQ1) .GT. ABS(DQ2)) GO TO 40 - DH21=-DY1/DX1 - DH12=DP2/DP1 -C - DU=ONE-DH12*DH21 -C - IF (.NOT. DU .LE. ZERO) GO TO 30 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 30 CONTINUE - DFLAG=ZERO - DD1=DD1/DU - DD2=DD2/DU - DX1=DX1*DU -C GO SCALE-CHECK.. - GO TO 100 - 40 CONTINUE - IF (.NOT. DQ2 .LT. ZERO) GO TO 50 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 50 CONTINUE - DFLAG=ONE - DH11=DP1/DP2 - DH22=DX1/DY1 - DU=ONE+DH11*DH22 - DTEMP=DD2/DU - DD2=DD1/DU - DD1=DTEMP - DX1=DY1*DU -C GO SCALE-CHECK - GO TO 100 -C PROCEDURE..ZERO-H-D-AND-DX1.. - 60 CONTINUE - DFLAG=-ONE - DH11=ZERO - DH12=ZERO - DH21=ZERO - DH22=ZERO -C - DD1=ZERO - DD2=ZERO - DX1=ZERO -C RETURN.. - GO TO 220 -C PROCEDURE..FIX-H.. - 70 CONTINUE - IF (.NOT. DFLAG .GE. ZERO) GO TO 90 -C - IF (.NOT. DFLAG .EQ. ZERO) GO TO 80 - DH11=ONE - DH22=ONE - DFLAG=-ONE - GO TO 90 - 80 CONTINUE - DH21=-ONE - DH12=ONE - DFLAG=-ONE - 90 CONTINUE -C GO TO IGO,(120,150,180,210) -C Replaced the above obsolete code with modern alternative (THC). - SELECT CASE(IGO) - CASE(120) - GO TO 120 - CASE(150) - GO TO 150 - CASE(180) - GO TO 180 - CASE(210) - GO TO 210 - END SELECT -C PROCEDURE..SCALE-CHECK - 100 CONTINUE - 110 CONTINUE - IF (.NOT. DD1 .LE. RGAMSQ) GO TO 130 - IF (DD1 .EQ. ZERO) GO TO 160 - IGO = 120 -C FIX-H.. - GO TO 70 - 120 CONTINUE - DD1=DD1*GAM**2 - DX1=DX1/GAM - DH11=DH11/GAM - DH12=DH12/GAM - GO TO 110 - 130 CONTINUE - 140 CONTINUE - IF (.NOT. DD1 .GE. GAMSQ) GO TO 160 - IGO = 150 -C FIX-H.. - GO TO 70 - 150 CONTINUE - DD1=DD1/GAM**2 - DX1=DX1*GAM - DH11=DH11*GAM - DH12=DH12*GAM - GO TO 140 - 160 CONTINUE - 170 CONTINUE - IF (.NOT. ABS(DD2) .LE. RGAMSQ) GO TO 190 - IF (DD2 .EQ. ZERO) GO TO 220 - IGO = 180 -C FIX-H.. - GO TO 70 - 180 CONTINUE - DD2=DD2*GAM**2 - DH21=DH21/GAM - DH22=DH22/GAM - GO TO 170 - 190 CONTINUE - 200 CONTINUE - IF (.NOT. ABS(DD2) .GE. GAMSQ) GO TO 220 - IGO = 210 -C FIX-H.. - GO TO 70 - 210 CONTINUE - DD2=DD2/GAM**2 - DH21=DH21*GAM - DH22=DH22*GAM - GO TO 200 - 220 CONTINUE -C IF (DFLAG) 250,230,240 -C Replaced obsolete code above with an IF-block (THC). - IF (DFLAG < 0) THEN - GO TO 250 - ELSE IF (DFLAG == 0) THEN - GO TO 230 - ELSE IF (DFLAG > 0) THEN - GO TO 240 - END IF - - 230 CONTINUE - DPARAM(3)=DH21 - DPARAM(4)=DH12 - GO TO 260 - 240 CONTINUE - DPARAM(2)=DH11 - DPARAM(5)=DH22 - GO TO 260 - 250 CONTINUE - DPARAM(2)=DH11 - DPARAM(3)=DH21 - DPARAM(4)=DH12 - DPARAM(5)=DH22 - 260 CONTINUE - DPARAM(1)=DFLAG - RETURN - END -*DECK DWNLIT - SUBROUTINE DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, - + RNORM, IDOPE, DOPE, DONE) -C***BEGIN PROLOGUE DWNLIT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DWNNLS -C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (WNLIT-S, DWNLIT-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to DWNNLS( ). -C The documentation for DWNNLS( ) has complete usage instructions. -C -C Note The M by (N+1) matrix W( , ) contains the rt. hand side -C B as the (N+1)st col. -C -C Triangularize L1 by L1 subsystem, where L1=MIN(M,L), with -C col interchanges. -C -C***SEE ALSO DWNNLS -C***ROUTINES CALLED DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, -C DSWAP, DWNLT1, DWNLT2, DWNLT3, IDAMAX -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -C 890620 Revised to make WNLT1, WNLT2, and WNLT3 subroutines. (RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900604 DP version created from SP version. . (RWC) -C***END PROLOGUE DWNLIT - USE REAL_PRECISION - - INTEGER IDOPE(*), IPIVOT(*), ITYPE(*), L, M, MDW, N - REAL(KIND=R8) DOPE(*), H(*), RNORM, SCALE(*), W(MDW,*) - LOGICAL DONE -C - EXTERNAL DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, - * DWNLT1, DWNLT2, DWNLT3, IDAMAX - INTEGER IDAMAX - LOGICAL DWNLT2 -C - REAL(KIND=R8) ALSQ, AMAX, EANORM, FACTOR, HBAR, RN, SPARAM(5), - * T, TAU - INTEGER I, I1, IMAX, IR, J, J1, JJ, JP, KRANK, L1, LB, LEND, ME, - * MEND, NIV, NSOLN - LOGICAL INDEP, RECALC -C -C***FIRST EXECUTABLE STATEMENT DWNLIT - ME = IDOPE(1) - NSOLN = IDOPE(2) - L1 = IDOPE(3) -C - ALSQ = DOPE(1) - EANORM = DOPE(2) - TAU = DOPE(3) -C - LB = MIN(M-1,L) - RECALC = .TRUE. - RNORM = 0.D0 - KRANK = 0 -C -C We set FACTOR=1.0 so that the heavy weight ALAMDA will be -C included in the test for column independence. -C - FACTOR = 1.D0 - LEND = L - DO 180 I=1,LB -C -C Set IR to point to the I-th row. -C - IR = I - MEND = M - CALL DWNLT1 (I, LEND, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, - + W) -C -C Update column SS and find pivot column. -C - CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange. -C Test independence of incoming column. -C - 130 IF (DWNLT2(ME, MEND, IR, FACTOR, TAU, SCALE, W(1,I))) THEN -C -C Eliminate I-th column below diagonal using modified Givens -C transformations applied to (A B). -C -C When operating near the ME line, use the largest element -C above it as the pivot. -C - DO 160 J=M,I+1,-1 - JP = J-1 - IF (J.EQ.ME+1) THEN - IMAX = ME - AMAX = SCALE(ME)*W(ME,I)**2 - DO 150 JP=J-1,I,-1 - T = SCALE(JP)*W(JP,I)**2 - IF (T.GT.AMAX) THEN - IMAX = JP - AMAX = T - ENDIF - 150 CONTINUE - JP = IMAX - ENDIF -C - IF (W(J,I).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(JP), SCALE(J), W(JP,I), - + W(J,I), SPARAM) - W(J,I) = 0.D0 - CALL SLATEC_DROTM (N+1-I, W(JP,I+1), MDW, W(J,I+1), - + MDW, SPARAM) - ENDIF - 160 CONTINUE - ELSE IF (LEND.GT.I) THEN -C -C Column I is dependent. Swap with column LEND. -C Perform column interchange, -C and find column in remaining set with largest SS. -C - CALL DWNLT3 (I, LEND, M, MDW, IPIVOT, H, W) - LEND = LEND - 1 - IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 - HBAR = H(IMAX) - GO TO 130 - ELSE - KRANK = I - 1 - GO TO 190 - ENDIF - 180 CONTINUE - KRANK = L1 -C - 190 IF (KRANK.LT.ME) THEN - FACTOR = ALSQ - DO 200 I=KRANK+1,ME - CALL DCOPY (L, 0.D0, 0, W(I,1), MDW) - 200 CONTINUE -C -C Determine the rank of the remaining equality constraint -C equations by eliminating within the block of constrained -C variables. Remove any redundant constraints. -C - RECALC = .TRUE. - LB = MIN(L+ME-KRANK, N) - DO 270 I=L+1,LB - IR = KRANK + I - L - LEND = N - MEND = ME - CALL DWNLT1 (I, LEND, ME, IR, MDW, RECALC, IMAX, HBAR, H, - + SCALE, W) -C -C Update col ss and find pivot col -C - CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange -C Eliminate elements in the I-th col. -C - DO 240 J=ME,IR+1,-1 - IF (W(J,I).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), - + W(J,I), SPARAM) - W(J,I) = 0.D0 - CALL SLATEC_DROTM (N+1-I, W(J-1,I+1), MDW,W(J,I+1), - + MDW, SPARAM) - ENDIF - 240 CONTINUE -C -C I=column being eliminated. -C Test independence of incoming column. -C Remove any redundant or dependent equality constraints. -C - IF (.NOT.DWNLT2(ME, MEND, IR, FACTOR,TAU,SCALE,W(1,I))) THEN - JJ = IR - DO 260 IR=JJ,ME - CALL DCOPY (N, 0.D0, 0, W(IR,1), MDW) - RNORM = RNORM + (SCALE(IR)*W(IR,N+1)/ALSQ)*W(IR,N+1) - W(IR,N+1) = 0.D0 - SCALE(IR) = 1.D0 -C -C Reclassify the zeroed row as a least squares equation. -C - ITYPE(IR) = 1 - 260 CONTINUE -C -C Reduce ME to reflect any discovered dependent equality -C constraints. -C - ME = JJ - 1 - GO TO 280 - ENDIF - 270 CONTINUE - ENDIF -C -C Try to determine the variables KRANK+1 through L1 from the -C least squares equations. Continue the triangularization with -C pivot element W(ME+1,I). -C - 280 IF (KRANK.LT.L1) THEN - RECALC = .TRUE. -C -C Set FACTOR=ALSQ to remove effect of heavy weight from -C test for column independence. -C - FACTOR = ALSQ - DO 350 I=KRANK+1,L1 -C -C Set IR to point to the ME+1-st row. -C - IR = ME+1 - LEND = L - MEND = M - CALL DWNLT1 (I, L, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, - + W) -C -C Update column SS and find pivot column. -C - CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange. -C Eliminate I-th column below the IR-th element. -C - DO 320 J=M,IR+1,-1 - IF (W(J,I).NE.0.D0) THEN - CALL SLATEC_DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), - + W(J,I), SPARAM) - W(J,I) = 0.D0 - CALL SLATEC_DROTM (N+1-I, W(J-1,I+1), MDW, W(J,I+1), - + MDW, SPARAM) - ENDIF - 320 CONTINUE -C -C Test if new pivot element is near zero. -C If so, the column is dependent. -C Then check row norm test to be classified as independent. -C - T = SCALE(IR)*W(IR,I)**2 - INDEP = T .GT. (TAU*EANORM)**2 - IF (INDEP) THEN - RN = 0.D0 - DO 340 I1=IR,M - DO 330 J1=I+1,N - RN = MAX(RN, SCALE(I1)*W(I1,J1)**2) - 330 CONTINUE - 340 CONTINUE - INDEP = T .GT. RN*TAU**2 - ENDIF -C -C If independent, swap the IR-th and KRANK+1-th rows to -C maintain the triangular form. Update the rank indicator -C KRANK and the equality constraint pointer ME. -C - IF (.NOT.INDEP) GO TO 360 - CALL DSWAP(N+1, W(KRANK+1,1), MDW, W(IR,1), MDW) - CALL DSWAP(1, SCALE(KRANK+1), 1, SCALE(IR), 1) -C -C Reclassify the least square equation as an equality -C constraint and rescale it. -C - ITYPE(IR) = 0 - T = SQRT(SCALE(KRANK+1)) - CALL DSCAL(N+1, T, W(KRANK+1,1), MDW) - SCALE(KRANK+1) = ALSQ - ME = ME+1 - KRANK = KRANK+1 - 350 CONTINUE - ENDIF -C -C If pseudorank is less than L, apply Householder transformation. -C from right. -C - 360 IF (KRANK.LT.L) THEN - DO 370 J=KRANK,1,-1 - CALL DH12 (1, J, KRANK+1, L, W(J,1), MDW, H(J), W, MDW, 1, - + J-1) - 370 CONTINUE - ENDIF -C - NIV = KRANK + NSOLN - L - IF (L.EQ.N) DONE = .TRUE. -C -C End of initial triangularization. -C - IDOPE(1) = ME - IDOPE(2) = KRANK - IDOPE(3) = NIV - RETURN - END -*DECK DWNLT1 - SUBROUTINE DWNLT1 (I, LEND, MEND, IR, MDW, RECALC, IMAX, HBAR, H, - + SCALE, W) -C***BEGIN PROLOGUE DWNLT1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (WNLT1-S, DWNLT1-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C To update the column Sum Of Squares and find the pivot column. -C The column Sum of Squares Vector will be updated at each step. -C When numerically necessary, these values will be recomputed. -C -C***SEE ALSO DWNLIT -C***ROUTINES CALLED IDAMAX -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DWNLT1 - USE REAL_PRECISION - - INTEGER I, IMAX, IR, LEND, MDW, MEND - REAL(KIND=R8) H(*), HBAR, SCALE(*), W(MDW,*) - LOGICAL RECALC -C - EXTERNAL IDAMAX - INTEGER IDAMAX -C - INTEGER J, K -C -C***FIRST EXECUTABLE STATEMENT DWNLT1 - IF (IR.NE.1 .AND. (.NOT.RECALC)) THEN -C -C Update column SS=sum of squares. -C - DO 10 J=I,LEND - H(J) = H(J) - SCALE(IR-1)*W(IR-1,J)**2 - 10 CONTINUE -C -C Test for numerical accuracy. -C - IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 - RECALC = (HBAR+1.E-3*H(IMAX)) .EQ. HBAR - ENDIF -C -C If required, recalculate column SS, using rows IR through MEND. -C - IF (RECALC) THEN - DO 30 J=I,LEND - H(J) = 0.D0 - DO 20 K=IR,MEND - H(J) = H(J) + SCALE(K)*W(K,J)**2 - 20 CONTINUE - 30 CONTINUE -C -C Find column with largest SS. -C - IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 - HBAR = H(IMAX) - ENDIF - RETURN - END -*DECK DWNLT2 - LOGICAL FUNCTION DWNLT2 (ME, MEND, IR, FACTOR, TAU, SCALE, WIC) -C***BEGIN PROLOGUE DWNLT2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (WNLT2-S, DWNLT2-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C To test independence of incoming column. -C -C Test the column IC to determine if it is linearly independent -C of the columns already in the basis. In the initial tri. step, -C we usually want the heavy weight ALAMDA to be included in the -C test for independence. In this case, the value of FACTOR will -C have been set to 1.E0 before this procedure is invoked. -C In the potentially rank deficient problem, the value of FACTOR -C will have been set to ALSQ=ALAMDA**2 to remove the effect of the -C heavy weight from the test for independence. -C -C Write new column as partitioned vector -C (A1) number of components in solution so far = NIV -C (A2) M-NIV components -C And compute SN = inverse weighted length of A1 -C RN = inverse weighted length of A2 -C Call the column independent when RN .GT. TAU*SN -C -C***SEE ALSO DWNLIT -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DWNLT2 - USE REAL_PRECISION - - REAL(KIND=R8) FACTOR, SCALE(*), TAU, WIC(*) - INTEGER IR, ME, MEND -C - REAL(KIND=R8) RN, SN, T - INTEGER J -C -C***FIRST EXECUTABLE STATEMENT DWNLT2 - SN = 0.E0 - RN = 0.E0 - DO 10 J=1,MEND - T = SCALE(J) - IF (J.LE.ME) T = T/FACTOR - T = T*WIC(J)**2 -C - IF (J.LT.IR) THEN - SN = SN + T - ELSE - RN = RN + T - ENDIF - 10 CONTINUE - DWNLT2 = RN .GT. SN*TAU**2 - RETURN - END -*DECK DWNLT3 - SUBROUTINE DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C***BEGIN PROLOGUE DWNLT3 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE REAL(KIND=R8) (WNLT3-S, DWNLT3-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Perform column interchange. -C Exchange elements of permuted index vector and perform column -C interchanges. -C -C***SEE ALSO DWNLIT -C***ROUTINES CALLED DSWAP -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DWNLT3 - USE REAL_PRECISION - - INTEGER I, IMAX, IPIVOT(*), M, MDW - REAL(KIND=R8) H(*), W(MDW,*) -C - EXTERNAL DSWAP -C - REAL(KIND=R8) T - INTEGER ITEMP -C -C***FIRST EXECUTABLE STATEMENT DWNLT3 - IF (IMAX.NE.I) THEN - ITEMP = IPIVOT(I) - IPIVOT(I) = IPIVOT(IMAX) - IPIVOT(IMAX) = ITEMP -C - CALL DSWAP(M, W(1,IMAX), 1, W(1,I), 1) -C - T = H(IMAX) - H(IMAX) = H(I) - H(I) = T - ENDIF - RETURN - END diff --git a/toms1012/test_install.f90 b/toms1012/test_install.f90 deleted file mode 100644 index 8868896..0000000 --- a/toms1012/test_install.f90 +++ /dev/null @@ -1,153 +0,0 @@ -PROGRAM TEST_INSTALL -! Driver code that tests the installation of DELAUNAYSPARSES and -! DELAUNAYSPARSEP. To do so, a toy interpolation problem is -! computed and the results are compared to the known solution. - -! Last Update: February, 2019 -! Primary Author: Tyler Chang -USE DELSPARSE_MOD -USE OMP_LIB -IMPLICIT NONE - -! Declare data. -INTEGER :: SIMPS(3,6), IERR(6) -REAL(KIND=R8) :: EPS -REAL(KIND=R8) :: INTERP_IN(1,20), INTERP_OUT(1,6), EXPECTED_OUT(1,6), & - & PTS(2,20), PTS_TMP(2,20), Q(2,6), Q_TMP(2,6), WEIGHTS(3,6) - -EPS = SQRT(EPSILON(0.0_R8)) -PTS = TRANSPOSE( RESHAPE( (/ & - 0.10877683233208346_R8, & - 0.65747571677546268_R8, & - 0.74853271200744009_R8, & - 0.25853058969031051_R8, & - 0.38508322804628770_R8, & - 0.19855613243388937_R8, & - 0.88590610193360986_R8, & - 0.73957680789581970_R8, & - 0.46130107231752082_R8, & - 0.61044888569019906_R8, & - 0.88848755836796889_R8, & - 0.56504950910258156_R8, & - 0.63374920061262452_R8, & - 0.47642100637444385_R8, & - 0.89167673297718886_R8, & - 0.85575976312324076_R8, & - 0.36741400280848768_R8, & - 0.22540743314109113_R8, & - 0.57887702455276135_R8, & - 0.33794226559725304_R8, & - 0.76211800269757757_R8, & - 0.082963515866522064_R8, & - 0.016220459783666152_R8, & - 0.17155847087049503_R8, & - 0.12930597950925682_R8, & - 0.91552991190955113_R8, & - 0.30469899967300274_R8, & - 0.064234640774060825_R8, & - 0.67129213095523377_R8, & - 0.56860397761470494_R8, & - 0.10547481357911370_R8, & - 0.59408216854500884_R8, & - 0.90989152079869851_R8, & - 0.91232248805035077_R8, & - 0.13873375923421827_R8, & - 0.68652421762380056_R8, & - 0.53775708104383380_R8, & - 0.63512621583969442_R8, & - 0.98798019619988187_R8, & - 0.87480704030477330_R8 /), & - (/ 20, 2 /) ) ) -Q = TRANSPOSE( RESHAPE( (/ & - 0.500000000000000000_R8, & - 0.250000000000000000_R8, & - 0.250000000000000000_R8, & - 0.750000000000000000_R8, & - 0.750000000000000000_R8, & - 0.100000000000000000_R8, & - 0.500000000000000000_R8, & - 0.250000000000000000_R8, & - 0.750000000000000000_R8, & - 0.250000000000000000_R8, & - 0.750000000000000000_R8, & - 0.500000000000000000_R8 /), & - (/6, 2/) ) ) -INTERP_IN = RESHAPE( (/ & - 0.87089483502966103_R8, & - 0.74043923264198475_R8, & - 0.76475317179110625_R8, & - 0.43008906056080554_R8, & - 0.51438920755554451_R8, & - 1.1140860443434404_R8, & - 1.1906051016066126_R8, & - 0.80381144866988052_R8, & - 1.1325932032727546_R8, & - 1.1790528633049040_R8, & - 0.99396237194708259_R8, & - 1.1591316776475904_R8, & - 1.5436407214113230_R8, & - 1.3887434944247947_R8, & - 1.0304104922114070_R8, & - 1.5422839807470412_R8, & - 0.90517108385232148_R8, & - 0.86053364898078555_R8, & - 1.5668572207526432_R8, & - 1.2127493059020265_R8 /), & - (/ 1, 20 /) ) -EXPECTED_OUT = RESHAPE( (/ & - 1.00000000000000000_R8, & - 0.50000000000000000_R8, & - 1.00000000000000000_R8, & - 1.00000000000000000_R8, & - 1.50000000000000000_R8, & - 0.68862615900613189_R8 /), & - (/ 1, 6/) ) - -! Test DELAUNAYSPARSES. -PTS_TMP = PTS; Q_TMP = Q -CALL DELAUNAYSPARSES(2, 20, PTS_TMP, 6, Q_TMP, SIMPS, WEIGHTS, IERR, & - & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT) -IF(ANY(ABS(INTERP_OUT - EXPECTED_OUT) > EPS)) THEN - WRITE(*,*) "DELAUNAYSPARSES produced an incorrect result. ", & - & " The installation is not correct." - STOP -END IF - -! Test DELAUNAYSPARSEP, PMODE=1. -PTS_TMP = PTS; Q_TMP = Q -CALL OMP_SET_NUM_THREADS(4) -CALL DELAUNAYSPARSEP(2, 20, PTS_TMP, 6, Q_TMP, SIMPS, WEIGHTS, IERR, & - & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT, PMODE=1) -IF(ANY(ABS(INTERP_OUT - EXPECTED_OUT) > EPS)) THEN - WRITE(*,*) "DELAUNAYSPARSEP produced an incorrect result. ", & - & " The installation is not correct." - STOP -END IF - -! Test DELAUNAYSPARSEP, PMODE=2. -PTS_TMP = PTS; Q_TMP = Q -CALL OMP_SET_NUM_THREADS(4) -CALL DELAUNAYSPARSEP(2, 20, PTS_TMP, 6, Q_TMP, SIMPS, WEIGHTS, IERR, & - & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT, PMODE=2) -IF(ANY(ABS(INTERP_OUT - EXPECTED_OUT) > EPS)) THEN - WRITE(*,*) "DELAUNAYSPARSEP produced an incorrect result. ", & - & " The installation is not correct." - STOP -END IF - -! Test DELAUNAYSPARSEP, PMODE=3. -CALL OMP_SET_NESTED(.TRUE.) -CALL OMP_SET_NUM_THREADS(2) -PTS_TMP = PTS; Q_TMP = Q -CALL DELAUNAYSPARSEP(2, 20, PTS_TMP, 6, Q_TMP, SIMPS, WEIGHTS, IERR, & - & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT, PMODE=3) -IF(ANY(ABS(INTERP_OUT - EXPECTED_OUT) > EPS)) THEN - WRITE(*,*) "DELAUNAYSPARSEP produced an incorrect result. ", & - & " The installation is not correct." - STOP -END IF - -! If all the tests passed, then the installation is correct. -WRITE(*,*) "The installation of DELAUNAYSPARSE appears correct." - -END PROGRAM TEST_INSTALL From bd2881c2399fbd80edec4faaff04ca8231f9123e Mon Sep 17 00:00:00 2001 From: Tyler Date: Tue, 31 May 2022 17:48:48 -0500 Subject: [PATCH 8/8] updated docs and website --- README.md | 1 + USAGE.md | 2 +- c_binding/LICENSE | 22 + c_binding/Makefile | 25 + c_binding/README | 42 + c_binding/blas.f | 2206 +++++++++ c_binding/delsparse.f90 | 2778 ++++++++++++ c_binding/delsparse.h | 59 + c_binding/delsparse_bind_c.f90 | 1265 ++++++ c_binding/lapack.f | 4369 ++++++++++++++++++ c_binding/slatec.f | 5023 ++++++++++++++++++++ c_binding/test_install.c | 149 + docs/LICENSE | 22 + docs/body.css | 249 + docs/c_delsparse.zip | Bin 0 -> 103216 bytes docs/delsparse.zip | Bin 0 -> 112772 bytes docs/index.html | 137 + docs/py_delsparse.zip | Bin 0 -> 119435 bytes docs/usergd.html | 872 ++++ python/LICENSE | 22 + python/README | 44 + python/delsparse.py | 759 ++++ python/delsparse_src/blas.f | 2206 +++++++++ python/delsparse_src/delsparse.f90 | 2774 ++++++++++++ python/delsparse_src/delsparse_bind_c.f90 | 4422 ++++++++++++++++++ python/delsparse_src/lapack.f | 4369 ++++++++++++++++++ python/delsparse_src/real_precision.f90 | 4 + python/delsparse_src/slatec.f | 5023 ++++++++++++++++++++ python/example.py | 131 + src/LICENSE | 22 + src/Makefile | 31 + src/README | 83 + src/blas.f | 2206 +++++++++ src/lapack.f | 4369 ++++++++++++++++++ src/sample_input2d.dat | 188 + src/sample_input4d.dat | 1297 ++++++ src/slatec.f | 5037 +++++++++++++++++++++ src/test_install.f90 | 153 + 38 files changed, 50360 insertions(+), 1 deletion(-) create mode 100644 c_binding/LICENSE create mode 100644 c_binding/Makefile create mode 100644 c_binding/README create mode 100644 c_binding/blas.f create mode 100644 c_binding/delsparse.f90 create mode 100644 c_binding/delsparse.h create mode 100644 c_binding/delsparse_bind_c.f90 create mode 100644 c_binding/lapack.f create mode 100644 c_binding/slatec.f create mode 100644 c_binding/test_install.c create mode 100644 docs/LICENSE create mode 100644 docs/body.css create mode 100644 docs/c_delsparse.zip create mode 100644 docs/delsparse.zip create mode 100644 docs/index.html create mode 100644 docs/py_delsparse.zip create mode 100644 docs/usergd.html create mode 100644 python/LICENSE create mode 100644 python/README create mode 100644 python/delsparse.py create mode 100755 python/delsparse_src/blas.f create mode 100644 python/delsparse_src/delsparse.f90 create mode 100644 python/delsparse_src/delsparse_bind_c.f90 create mode 100755 python/delsparse_src/lapack.f create mode 100644 python/delsparse_src/real_precision.f90 create mode 100755 python/delsparse_src/slatec.f create mode 100644 python/example.py create mode 100644 src/LICENSE create mode 100644 src/Makefile create mode 100644 src/README create mode 100644 src/blas.f create mode 100644 src/lapack.f create mode 100644 src/sample_input2d.dat create mode 100644 src/sample_input4d.dat create mode 100644 src/slatec.f create mode 100644 src/test_install.f90 diff --git a/README.md b/README.md index bdaad61..ec28fed 100644 --- a/README.md +++ b/README.md @@ -54,6 +54,7 @@ The physical organization is as follows. A test file `test_install.c` can be used for usage examples. This directory's internal README also contains best practices when calling Fortran from C/C++. + * `docs` contains the html source for generating the DelaunaySparse website. * `USAGE` provides additional detailed user information. * DelaunaySparse is shared under the MIT Software License, in the `LICENSE` file. diff --git a/USAGE.md b/USAGE.md index 70102a0..d09f3c5 100644 --- a/USAGE.md +++ b/USAGE.md @@ -1,4 +1,4 @@ -# Usage Information for using DELAUNAYSPARSE. +# Usage Information for DELAUNAYSPARSE. DELAUNAYSPARSE solves the multivariate interpolation problem: diff --git a/c_binding/LICENSE b/c_binding/LICENSE new file mode 100644 index 0000000..00ce8f0 --- /dev/null +++ b/c_binding/LICENSE @@ -0,0 +1,22 @@ +MIT License + +Copyright (c) 2020 Tyler H. Chang, Layne T. Watson, Thomas C. H. Lux, +Ali R. Butt, Kirk W. Cameron, and Yili Hong. + +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, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +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. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/c_binding/Makefile b/c_binding/Makefile new file mode 100644 index 0000000..592d3ef --- /dev/null +++ b/c_binding/Makefile @@ -0,0 +1,25 @@ +FORT = gfortran +CC = gcc +CFLAGS = -c +OPTS = -fopenmp +LIBS = blas.f lapack.f +LEGACY = -std=legacy + +all: test_install.o delsparse_bind_c.o delsparse.o slatec.o delsparse.h + $(FORT) $(OPTS) test_install.o delsparse_bind_c.o delsparse.o slatec.o $(LIBS) -o test_install + ./test_install + +test_install.o: test_install.c + $(CC) $(CFLAGS) test_install.c -o test_install.o + +delsparse_bind_c.o: delsparse_bind_c.f90 delsparse.o + $(FORT) $(CFLAGS) $(OPTS) delsparse_bind_c.f90 -o delsparse_bind_c.o + +delsparse.o: delsparse.f90 + $(FORT) $(CFLAGS) $(OPTS) delsparse.f90 -o delsparse.o + +slatec.o : slatec.f + $(FORT) $(CFLAGS) $(OPTS) $(LEGACY) slatec.f -o slatec.o + +clean: + rm -f *.o *.mod test_install diff --git a/c_binding/README b/c_binding/README new file mode 100644 index 0000000..37e65d3 --- /dev/null +++ b/c_binding/README @@ -0,0 +1,42 @@ +C bindings for the DELAUNAYSPARSE Fortran package. + + +REQUIREMENTS: + + A Fortran compiler that supports BIND(C). + +USAGE: + + Use the C bindings in delsparse_bind_c.f90 to call DELAUNAYSPARSE from + inside a C/C++ program. + + Because C does not support optional arguments, there are 4 variations of + DELAUNAYSPARSE{S|P}: + * c_delaunaysparse{s|p} accepts none of the optional arguments; + * c_delaunaysparse{s|p}_interp accepts an integer ir for specifying the + dimension of the response variables, plus the two variables needed + for computing the value of the interpolant, interp_in and interp_out; + * c_delaunaysparse{s|p}_opts accepts all of the optional arguments + EXCEPT interp_in and interp_out; + * c_delaunaysparse{s|p}_interp_opts accepts all of the optional arguments, + plus the response dimension ir, which cannot be inferred as it is by + the Fortran subroutines. + + When using the 4 subroutines above, keep in mind the following: + * C passes by copy and Fortran passes by reference. Therefore, any non-array + type variable must be manually passed by address (i.e., by using the `&` + character); + * C matrices are stored in row major ordering, while Fortran stores in + column major ordering. Therefore, your data may need to be transposed + before calling any of the above subroutines; + * In C, a double-indexed array is treated as an array of pointers, whereas + Fortran expects a contiguous chunk of memory. Often, it is better to + allocate a one-dimensional array and manually index it, then pass this + "flat" array to the Fortran subroutine. + + Usage examples are provided in the sample file, test_install.c. + +CONTRIBUTORS: + + Tyler Chang, tchang@anl.gov + diff --git a/c_binding/blas.f b/c_binding/blas.f new file mode 100644 index 0000000..df991ff --- /dev/null +++ b/c_binding/blas.f @@ -0,0 +1,2206 @@ + +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* ====================================== + + DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* Purpose: +* ============= +* +* DASUM takes the sum of the absolute values. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 3/93 to return if incx .le. 0. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,M,MP1,NINCX +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS,MOD +* .. + DASUM = 0.0D0 + DTEMP = 0.0D0 + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,6) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DTEMP + DABS(DX(I)) + END DO + IF (N.LT.6) THEN + DASUM = DTEMP + RETURN + END IF + END IF + MP1 = M + 1 + DO I = MP1,N,6 + DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) + + $ DABS(DX(I+2)) + DABS(DX(I+3)) + + $ DABS(DX(I+4)) + DABS(DX(I+5)) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + DTEMP = DTEMP + DABS(DX(I)) + END DO + END IF + DASUM = DTEMP + RETURN + END + + SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* Purpose: +* ============= +* +* DAXPY constant times a vector plus a vector. +* uses unrolled loops for increments equal to one. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DA is DOUBLE PRECISION. On entry, DA specifies the scalar alpha. +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +* +* INCY is INTEGER storage spacing between elements of DY +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (DA.EQ.0.0D0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,4) + IF (M.NE.0) THEN + DO I = 1,M + DY(I) = DY(I) + DA*DX(I) + END DO + END IF + IF (N.LT.4) RETURN + MP1 = M + 1 + DO I = MP1,N,4 + DY(I) = DY(I) + DA*DX(I) + DY(I+1) = DY(I+1) + DA*DX(I+1) + DY(I+2) = DY(I+2) + DA*DX(I+2) + DY(I+3) = DY(I+3) + DA*DX(I+3) + END DO + ELSE +* +* code for unequal increments or equal increments +* 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 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN + END + + SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* Purpose: +* ============= +* +* DCOPY copies a vector, x, to a vector, y. +* uses unrolled loops for increments equal to 1. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +* +* INCY is INTEGER storage spacing between elements of DY +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,7) + IF (M.NE.0) THEN + DO I = 1,M + DY(I) = DX(I) + END DO + IF (N.LT.7) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,7 + DY(I) = DX(I) + DY(I+1) = DX(I+1) + DY(I+2) = DX(I+2) + DY(I+3) = DX(I+3) + DY(I+4) = DX(I+4) + DY(I+5) = DX(I+5) + DY(I+6) = DX(I+6) + END DO + ELSE +* +* code for unequal increments or equal increments +* 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 I = 1,N + DY(IY) = DX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN + END + + DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* Purpose: +* ============= +* +* DDOT forms the dot product of two vectors. +* uses unrolled loops for increments equal to one. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +* +* INCY is INTEGER storage spacing between elements of DY +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + DDOT = 0.0D0 + DTEMP = 0.0D0 + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DTEMP + DX(I)*DY(I) + END DO + IF (N.LT.5) THEN + DDOT=DTEMP + RETURN + END IF + END IF + MP1 = M + 1 + DO I = MP1,N,5 + DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) + + $ DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) + END DO + ELSE +* +* code for unequal increments or equal increments +* 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 I = 1,N + DTEMP = DTEMP + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + DDOT = DTEMP + RETURN + END + + SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of +* Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB + LOGICAL NOTA,NOTB +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are +* not +* transposed and set NROWA, NCOLA and NROWB as the number of +* rows +* and columns of A and the number of rows of B +* respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + IF (NOTA) THEN + NROWA = M + NCOLA = K + ELSE + NROWA = K + NCOLA = M + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And if alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF (NOTA) THEN +* +* Form C := alpha*A*B**T + beta*C +* + DO 170 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 130 I = 1,M + C(I,J) = ZERO + 130 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 140 I = 1,M + C(I,J) = BETA*C(I,J) + 140 CONTINUE + END IF + DO 160 L = 1,K + TEMP = ALPHA*B(J,L) + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 200 J = 1,N + DO 190 I = 1,M + TEMP = ZERO + DO 180 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 180 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMM . +* + END + + SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER INCX,INCY,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* Purpose: +* ============= +* +* DGEMV performs one of the matrix-vector operations +* +* y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, +* +* where alpha and beta are scalars, x and y are vectors and A is an +* m by n matrix. +* +* Arguments: +* ========== +* +* TRANS is CHARACTER*1 +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +* +* TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. +* +* TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. +* M is INTEGER +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* +* N is INTEGER +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* +* ALPHA is DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* +* A is DOUBLE PRECISION array, dimension ( LDA, N ) +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* +* LDA is INTEGER +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* +* X is DOUBLE PRECISION array, dimension at least +* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +* Before entry, the incremented array X must contain the +* vector x. +* +* INCX is INTEGER +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* +* BETA is DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* +* Y is DOUBLE PRECISION array, dimension at least +* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY is INTEGER +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* +* Further Details: +* ===================== +* +* Level 2 Blas routine. +* The vector and matrix arguments are not referenced when N = 0, or M = 0 +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 1 + ELSE IF (M.LT.0) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + ELSE IF (INCY.EQ.0) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGEMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF (LSAME(TRANS,'N')) THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (LENX-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (LENY-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,LENY + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,LENY + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,LENY + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,LENY + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(TRANS,'N')) THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF (INCY.EQ.1) THEN + DO 60 J = 1,N + TEMP = ALPHA*X(JX) + DO 50 I = 1,M + Y(I) = Y(I) + TEMP*A(I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + DO 70 I = 1,M + Y(IY) = Y(IY) + TEMP*A(I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = ZERO + DO 90 I = 1,M + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120 J = 1,N + TEMP = ZERO + IX = KX + DO 110 I = 1,M + TEMP = TEMP + A(I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMV . +* + END + + SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of +* Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER(ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JY,KX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (M.LT.0) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGER ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (INCY.GT.0) THEN + JY = 1 + ELSE + JY = 1 - (N-1)*INCY + END IF + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + DO 10 I = 1,M + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + JY = JY + INCY + 20 CONTINUE + ELSE + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (M-1)*INCX + END IF + DO 40 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + IX = KX + DO 30 I = 1,M + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JY = JY + INCY + 40 CONTINUE + END IF +* + RETURN +* +* End of DGER . +* + END + + DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION X(*) +* .. +* +* Purpose: +* ============= +* +* DNRM2 returns the euclidean norm of a vector via the function +* name, so that +* +* DNRM2 := sqrt( x'*x ) +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* Further Details: +* ===================== +* +* -- This version written on 25-October-1982. +* Modified on 14-October-1993 to inline the call to DLASSQ. +* Sven Hammarling, Nag Ltd. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ + INTEGER IX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS,SQRT +* .. + IF (N.LT.1 .OR. INCX.LT.1) THEN + NORM = ZERO + ELSE IF (N.EQ.1) THEN + NORM = ABS(X(1)) + ELSE + SCALE = ZERO + SSQ = ONE +* The following loop is equivalent to this call to the LAPACK +* auxiliary routine: +* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) +* + DO 10 IX = 1,1 + (N-1)*INCX,INCX + IF (X(IX).NE.ZERO) THEN + ABSXI = ABS(X(IX)) + IF (SCALE.LT.ABSXI) THEN + SSQ = ONE + SSQ* (SCALE/ABSXI)**2 + SCALE = ABSXI + ELSE + SSQ = SSQ + (ABSXI/SCALE)**2 + END IF + END IF + 10 CONTINUE + NORM = SCALE*SQRT(SSQ) + END IF +* + DNRM2 = NORM + RETURN +* +* End of DNRM2. +* + END + + SUBROUTINE DSCAL(N,DA,DX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* Purpose: +* ============= +* +* DSCAL scales a vector by a constant. +* uses unrolled loops for increment equal to 1. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DA is DOUBLE PRECISION On entry, DA specifies the scalar alpha. +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 3/93 to return if incx .le. 0. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,M,MP1,NINCX +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + DX(I) = DA*DX(I) + END DO + IF (N.LT.5) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I+1) = DA*DX(I+1) + DX(I+2) = DA*DX(I+2) + DX(I+3) = DA*DX(I+3) + DX(I+4) = DA*DX(I+4) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + DX(I) = DA*DX(I) + END DO + END IF + RETURN + END + + SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* Purpose: +* ============= +* +* DSWAP interchanges two vectors. +* uses unrolled loops for increments equal to 1. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +* +* INCY is INTEGER storage spacing between elements of DY +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,3) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + END DO + IF (N.LT.3) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,3 + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + DTEMP = DX(I+1) + DX(I+1) = DY(I+1) + DY(I+1) = DTEMP + DTEMP = DX(I+2) + DX(I+2) = DY(I+2) + DY(I+2) = DTEMP + END DO + ELSE +* +* code for unequal increments or equal increments 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 I = 1,N + DTEMP = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN + END + + SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of +* Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOUNIT,UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTRMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*A*B. +* + IF (UPPER) THEN + DO 50 J = 1,N + DO 40 K = 1,M + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + DO 30 I = 1,K - 1 + B(I,J) = B(I,J) + TEMP*A(I,K) + 30 CONTINUE + IF (NOUNIT) TEMP = TEMP*A(K,K) + B(K,J) = TEMP + END IF + 40 CONTINUE + 50 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + B(K,J) = TEMP + IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) + DO 60 I = K + 1,M + B(I,J) = B(I,J) + TEMP*A(I,K) + 60 CONTINUE + END IF + 70 CONTINUE + 80 CONTINUE + END IF + ELSE +* +* Form B := alpha*A**T*B. +* + IF (UPPER) THEN + DO 110 J = 1,N + DO 100 I = M,1,-1 + TEMP = B(I,J) + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 90 K = 1,I - 1 + TEMP = TEMP + A(K,I)*B(K,J) + 90 CONTINUE + B(I,J) = ALPHA*TEMP + 100 CONTINUE + 110 CONTINUE + ELSE + DO 140 J = 1,N + DO 130 I = 1,M + TEMP = B(I,J) + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 120 K = I + 1,M + TEMP = TEMP + A(K,I)*B(K,J) + 120 CONTINUE + B(I,J) = ALPHA*TEMP + 130 CONTINUE + 140 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*A. +* + IF (UPPER) THEN + DO 180 J = N,1,-1 + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = 1,M + B(I,J) = TEMP*B(I,J) + 150 CONTINUE + DO 170 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 160 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + ELSE + DO 220 J = 1,N + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 190 I = 1,M + B(I,J) = TEMP*B(I,J) + 190 CONTINUE + DO 210 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 200 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 200 CONTINUE + END IF + 210 CONTINUE + 220 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*A**T. +* + IF (UPPER) THEN + DO 260 K = 1,N + DO 240 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + TEMP = ALPHA*A(J,K) + DO 230 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 230 CONTINUE + END IF + 240 CONTINUE + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(K,K) + IF (TEMP.NE.ONE) THEN + DO 250 I = 1,M + B(I,K) = TEMP*B(I,K) + 250 CONTINUE + END IF + 260 CONTINUE + ELSE + DO 300 K = N,1,-1 + DO 280 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + TEMP = ALPHA*A(J,K) + DO 270 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 270 CONTINUE + END IF + 280 CONTINUE + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(K,K) + IF (TEMP.NE.ONE) THEN + DO 290 I = 1,M + B(I,K) = TEMP*B(I,K) + 290 CONTINUE + END IF + 300 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRMM . +* + END + + SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of +* Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER(ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTRMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := A*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*A(I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 I = 1,J - 1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*A(I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 70 I = N,J + 1,-1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 100 J = N,1,-1 + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 90 I = J - 1,1,-1 + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + X(J) = TEMP + 100 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 120 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 110 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + A(I,J)*X(IX) + 110 CONTINUE + X(JX) = TEMP + JX = JX - INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = 1,N + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 130 I = J + 1,N + TEMP = TEMP + A(I,J)*X(I) + 130 CONTINUE + X(J) = TEMP + 140 CONTINUE + ELSE + JX = KX + DO 160 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + A(I,J)*X(IX) + 150 CONTINUE + X(JX) = TEMP + JX = JX + INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRMV . +* + END + + SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*) +* .. +* +* Purpose: +* ============= +* +* DTRSM solves one of the matrix equations +* +* op( A )*X = alpha*B, or X*op( A ) = alpha*B, +* +* where alpha is a scalar, X and B are m by n matrices, A is a unit, or +* non-unit, upper or lower triangular matrix and op( A ) is one of +* +* op( A ) = A or op( A ) = A**T. +* +* The matrix X is overwritten on B. +* +* Arguments: +* ========== +* +* SIDE is CHARACTER*1 +* On entry, SIDE specifies whether op( A ) appears on the left +* or right of X as follows: +* +* SIDE = 'L' or 'l' op( A )*X = alpha*B. +* +* SIDE = 'R' or 'r' X*op( A ) = alpha*B. +* +* UPLO is CHARACTER*1 +* On entry, UPLO specifies whether the matrix A is an upper or +* lower triangular matrix as follows: +* +* UPLO = 'U' or 'u' A is an upper triangular matrix. +* +* UPLO = 'L' or 'l' A is a lower triangular matrix. +* +* TRANSA is CHARACTER*1 +* On entry, TRANSA specifies the form of op( A ) to be used in +* the matrix multiplication as follows: +* +* TRANSA = 'N' or 'n' op( A ) = A. +* +* TRANSA = 'T' or 't' op( A ) = A**T. +* +* TRANSA = 'C' or 'c' op( A ) = A**T. +* +* DIAG is CHARACTER*1 +* On entry, DIAG specifies whether or not A is unit triangular +* as follows: +* +* DIAG = 'U' or 'u' A is assumed to be unit triangular. +* +* DIAG = 'N' or 'n' A is not assumed to be unit +* triangular. +* +* M is INTEGER +* On entry, M specifies the number of rows of B. M must be at +* least zero. +* +* N is INTEGER +* On entry, N specifies the number of columns of B. N must be +* at least zero. +* +* ALPHA is DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. When alpha is +* zero then A is not referenced and B need not be set before +* entry. +* +* A is DOUBLE PRECISION array, dimension ( LDA, k ), +* where k is m when SIDE = 'L' or 'l' +* and k is n when SIDE = 'R' or 'r'. +* Before entry with UPLO = 'U' or 'u', the leading k by k +* upper triangular part of the array A must contain the upper +* triangular matrix and the strictly lower triangular part of +* A is not referenced. +* Before entry with UPLO = 'L' or 'l', the leading k by k +* lower triangular part of the array A must contain the lower +* triangular matrix and the strictly upper triangular part of +* A is not referenced. +* Note that when DIAG = 'U' or 'u', the diagonal elements of +* A are not referenced either, but are assumed to be unity. +* +* LDA is INTEGER +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When SIDE = 'L' or 'l' then +* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +* then LDA must be at least max( 1, n ). +* +* B is DOUBLE PRECISION array, dimension ( LDB, N ) +* Before entry, the leading m by n part of the array B must +* contain the right-hand side matrix B, and on exit is +* overwritten by the solution matrix X. +* +* LDB is INTEGER +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. LDB must be at least +* max( 1, m ). +* +* Further Details: +* ===================== +* +* Level 3 Blas routine. +* +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOUNIT,UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTRSM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*inv( A )*B. +* + IF (UPPER) THEN + DO 60 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 30 I = 1,M + B(I,J) = ALPHA*B(I,J) + 30 CONTINUE + END IF + DO 50 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 40 I = 1,K - 1 + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 40 CONTINUE + END IF + 50 CONTINUE + 60 CONTINUE + ELSE + DO 100 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 70 I = 1,M + B(I,J) = ALPHA*B(I,J) + 70 CONTINUE + END IF + DO 90 K = 1,M + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 80 I = K + 1,M + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 80 CONTINUE + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form B := alpha*inv( A**T )*B. +* + IF (UPPER) THEN + DO 130 J = 1,N + DO 120 I = 1,M + TEMP = ALPHA*B(I,J) + DO 110 K = 1,I - 1 + TEMP = TEMP - A(K,I)*B(K,J) + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + B(I,J) = TEMP + 120 CONTINUE + 130 CONTINUE + ELSE + DO 160 J = 1,N + DO 150 I = M,1,-1 + TEMP = ALPHA*B(I,J) + DO 140 K = I + 1,M + TEMP = TEMP - A(K,I)*B(K,J) + 140 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + B(I,J) = TEMP + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*inv( A ). +* + IF (UPPER) THEN + DO 210 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 170 I = 1,M + B(I,J) = ALPHA*B(I,J) + 170 CONTINUE + END IF + DO 190 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + DO 180 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 180 CONTINUE + END IF + 190 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 200 I = 1,M + B(I,J) = TEMP*B(I,J) + 200 CONTINUE + END IF + 210 CONTINUE + ELSE + DO 260 J = N,1,-1 + IF (ALPHA.NE.ONE) THEN + DO 220 I = 1,M + B(I,J) = ALPHA*B(I,J) + 220 CONTINUE + END IF + DO 240 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + DO 230 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 230 CONTINUE + END IF + 240 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 250 I = 1,M + B(I,J) = TEMP*B(I,J) + 250 CONTINUE + END IF + 260 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*inv( A**T ). +* + IF (UPPER) THEN + DO 310 K = N,1,-1 + IF (NOUNIT) THEN + TEMP = ONE/A(K,K) + DO 270 I = 1,M + B(I,K) = TEMP*B(I,K) + 270 CONTINUE + END IF + DO 290 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + TEMP = A(J,K) + DO 280 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 280 CONTINUE + END IF + 290 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 300 I = 1,M + B(I,K) = ALPHA*B(I,K) + 300 CONTINUE + END IF + 310 CONTINUE + ELSE + DO 360 K = 1,N + IF (NOUNIT) THEN + TEMP = ONE/A(K,K) + DO 320 I = 1,M + B(I,K) = TEMP*B(I,K) + 320 CONTINUE + END IF + DO 340 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + TEMP = A(J,K) + DO 330 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 330 CONTINUE + END IF + 340 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 350 I = 1,M + B(I,K) = ALPHA*B(I,K) + 350 CONTINUE + END IF + 360 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRSM . +* + END + + INTEGER FUNCTION IDAMAX(N,DX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* Purpose: +* ============= +* +* IDAMAX finds the index of the first element having maximum absolute value. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of SX +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 3/93 to return if incx .le. 0. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DMAX + INTEGER I,IX +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS +* .. + IDAMAX = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + IDAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DMAX = DABS(DX(1)) + DO I = 2,N + IF (DABS(DX(I)).GT.DMAX) THEN + IDAMAX = I + DMAX = DABS(DX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + DMAX = DABS(DX(1)) + IX = IX + INCX + DO I = 2,N + IF (DABS(DX(IX)).GT.DMAX) THEN + IDAMAX = I + DMAX = DABS(DX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN + END + + LOGICAL FUNCTION LSAME(CA,CB) +* +* -- Reference BLAS level1 routine (version 3.1) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER CA,CB +* .. +* +* Purpose: +* ============= +* +* LSAME returns .TRUE. if CA is the same letter as CB regardless of +* case. +* +* Arguments: +* ========== +* +* CA is CHARACTER*1 +* CB is CHARACTER*1 +* CA and CB specify the single characters to be compared. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA,INTB,ZCODE +* .. +* +* Test if the characters are equal +* + LSAME = CA .EQ. CB + IF (LSAME) RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + ZCODE = ICHAR('Z') +* +* Use 'Z' rather than 'A' so that ASCII can be detected on Prime +* machines, on which ICHAR returns a value with bit 8 set. +* ICHAR('A') on Prime machines returns 193 which is the same as +* ICHAR('A') on an EBCDIC machine. +* + INTA = ICHAR(CA) + INTB = ICHAR(CB) +* + IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 + IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 +* + ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.129 .AND. INTA.LE.137 .OR. + + INTA.GE.145 .AND. INTA.LE.153 .OR. + + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 + IF (INTB.GE.129 .AND. INTB.LE.137 .OR. + + INTB.GE.145 .AND. INTB.LE.153 .OR. + + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 +* + ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 + IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 + END IF + LSAME = INTA .EQ. INTB +* +* RETURN +* +* End of LSAME +* + END + + SUBROUTINE XERBLA( SRNAME, INFO ) +* +* -- Reference BLAS level1 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER*(*) SRNAME + INTEGER INFO +* .. +* +* Purpose: +* ============= +* +* XERBLA is an error handler for the LAPACK routines. +* It is called by an LAPACK routine if an input parameter has an +* invalid value. A message is printed and execution stops. +* +* Installers may consider modifying the STOP statement in order to +* call system-specific exception-handling facilities. +* +* Arguments: +* ========== +* +* SRNAME is CHARACTER*(*) +* The name of the routine which called XERBLA. +* +* INFO is INTEGER +* The position of the invalid parameter in the parameter list +* of the calling routine. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM +* .. +* .. Executable Statements .. +* + WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO +* + STOP +* + 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END + diff --git a/c_binding/delsparse.f90 b/c_binding/delsparse.f90 new file mode 100644 index 0000000..b093f9a --- /dev/null +++ b/c_binding/delsparse.f90 @@ -0,0 +1,2778 @@ +MODULE REAL_PRECISION ! HOMPACK90 module for 64-bit arithmetic. +INTEGER, PARAMETER:: R8=SELECTED_REAL_KIND(13) +END MODULE REAL_PRECISION + +MODULE DELSPARSE_MOD +! This module contains the REAL_PRECISION R8 data type for 64-bit arithmetic +! and interface blocks for the DELAUNAYSPARSES and DELAUNAYSPARSEP +! subroutines for computing the Delaunay simplices containing interpolation +! points Q in R^D given data points PTS. +USE REAL_PRECISION +PUBLIC + +INTERFACE + ! Interface for serial subroutine DELAUNAYSPARSES. + SUBROUTINE DELAUNAYSPARSES( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, & + IBUDGET, CHAIN, EXACT ) + USE REAL_PRECISION, ONLY : R8 + INTEGER, INTENT(IN) :: D, N + REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) + INTEGER, INTENT(IN) :: M + REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) + INTEGER, INTENT(OUT) :: SIMPS(:,:) + REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) + INTEGER, INTENT(OUT) :: IERR(:) + REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) + REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) + INTEGER, INTENT(IN), OPTIONAL :: IBUDGET + LOGICAL, INTENT(IN), OPTIONAL :: CHAIN + LOGICAL, INTENT(IN), OPTIONAL :: EXACT + END SUBROUTINE DELAUNAYSPARSES + + ! Interface for parallel subroutine DELAUNAYSPARSEP. + SUBROUTINE DELAUNAYSPARSEP( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, & + IBUDGET, CHAIN, EXACT, PMODE ) + USE REAL_PRECISION, ONLY : R8 + INTEGER, INTENT(IN) :: D, N + REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) + INTEGER, INTENT(IN) :: M + REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) + INTEGER, INTENT(OUT) :: SIMPS(:,:) + REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) + INTEGER, INTENT(OUT) :: IERR(:) + REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) + REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) + INTEGER, INTENT(IN), OPTIONAL :: IBUDGET + LOGICAL, INTENT(IN), OPTIONAL :: CHAIN + LOGICAL, INTENT(IN), OPTIONAL :: EXACT + INTEGER, INTENT(IN), OPTIONAL :: PMODE + END SUBROUTINE DELAUNAYSPARSEP + + ! Interface for SLATEC subroutine DWNNLS. + SUBROUTINE DWNNLS( W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, & + MODE, IWORK, WORK ) + USE REAL_PRECISION, ONLY : R8 + INTEGER :: IWORK(*), L, MA, MDW, ME, MODE, N + REAL(KIND=R8) :: PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) + END SUBROUTINE DWNNLS + +END INTERFACE + +END MODULE DELSPARSE_MOD + +SUBROUTINE DELAUNAYSPARSES( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EXACT ) +! This is a serial implementation of an algorithm for efficiently performing +! interpolation in R^D via the Delaunay triangulation. The algorithm is fully +! described and analyzed in +! +! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. +! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate +! interpolation in arbitrary dimension via the Delaunay triangulation. In +! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, +! USA. Article 12, 8 pages. +! +! +! On input: +! +! D is the dimension of the space for PTS and Q. +! +! N is the number of data points in PTS. +! +! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the +! coordinates of a single data point in R^D. +! +! M is the number of interpolation points in Q. +! +! Q(1:D,1:M) is a real valued matrix with M columns, each containing the +! coordinates of a single interpolation point in R^D. +! +! +! On output: +! +! PTS and Q have been rescaled and shifted. All the data points in PTS +! are now contained in the unit hyperball in R^D, and the points in Q +! have been shifted and scaled accordingly in relation to PTS. +! +! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns +! in PTS) for the D+1 vertices of the Delaunay simplex containing each +! interpolation point in Q. +! +! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each +! point in Q as a convex combination of the D+1 corresponding vertices +! in SIMPS. +! +! IERR(1:M) contains integer valued error flags associated with the +! computation of each of the M interpolation points in Q. The error +! codes are: +! +! 00 : Succesful interpolation. +! 01 : Succesful extrapolation (up to the allowed extrapolation distance). +! 02 : This point was outside the allowed extrapolation distance; the +! corresponding entries in SIMPS and WEIGHTS contain zero values. +! +! 10 : The dimension D must be positive. +! 11 : Too few data points to construct a triangulation (i.e., N < D+1). +! 12 : No interpolation points given (i.e., M < 1). +! 13 : The first dimension of PTS does not agree with the dimension D. +! 14 : The second dimension of PTS does not agree with the number of points N. +! 15 : The first dimension of Q does not agree with the dimension D. +! 16 : The second dimension of Q does not agree with the number of +! interpolation points M. +! 17 : The first dimension of the output array SIMPS does not match the number +! of vertices needed for a D-simplex (D+1). +! 18 : The second dimension of the output array SIMPS does not match the +! number of interpolation points M. +! 19 : The first dimension of the output array WEIGHTS does not match the +! number of vertices for a a D-simplex (D+1). +! 20 : The second dimension of the output array WEIGHTS does not match the +! number of interpolation points M. +! 21 : The size of the error array IERR does not match the number of +! interpolation points M. +! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. +! 23 : The first dimension of INTERP_IN does not match the first +! dimension of INTERP_OUT. +! 24 : The second dimension of INTERP_IN does not match the number of +! data points PTS. +! 25 : The second dimension of INTERP_OUT does not match the number of +! interpolation points M. +! 26 : The budget supplied in IBUDGET does not contain a positive +! integer. +! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. +! 28 : The size of the RNORM output array does not match the number of +! interpolation points M. +! +! 30 : Two or more points in the data set PTS are too close together with +! respect to the working precision (EPS), which would result in a +! numerically degenerate simplex. +! 31 : All the data points in PTS lie in some lower dimensional linear +! manifold (up to the working precision), and no valid triangulation +! exists. +! 40 : An error caused DELAUNAYSPARSES to terminate before this value could +! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may +! contain garbage values. +! +! 50 : A memory allocation error occurred while allocating the work array +! WORK. +! +! 60 : The budget was exceeded before the algorithm converged on this +! value. If the dimension is high, try increasing IBUDGET. This +! error can also be caused by a working precision EPS that is too +! small for the conditioning of the problem. +! +! 61 : A value that was judged appropriate later caused LAPACK to encounter a +! singularity. Try increasing the value of EPS. +! +! 70 : Allocation error for the extrapolation work arrays. +! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection +! of an extrapolation point onto the convex hull. +! 72 : The SLATEC subroutine DWNNLS has reported a usage error. +! +! The errors 72, 80--83 should never occur, and likely indicate a +! compiler bug or hardware failure. +! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. +! 81 : The LAPACK subroutine DGETRF has reported an illegal value. +! 82 : The LAPACK subroutine DGETRS has reported an illegal value. +! 83 : The LAPACK subroutine DORMQR has reported an illegal value. +! +! +! Optional arguments: +! +! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of +! the data points in PTS on input. The first dimension of INTERP_IN is +! inferred to be the dimension of these response vectors, and the +! second dimension must match N. If present, the response values will +! be computed for each interpolation point in Q, and stored in INTERP_OUT, +! which therefore must also be present. If both INTERP_IN and INTERP_OUT +! are omitted, only the containing simplices and convex combination +! weights are returned. +! +! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each +! interpolation point in Q on output. The first dimension of INTERP_OUT +! must match the first dimension of INTERP_IN, and the second dimension +! must match M. If present, the response values at each interpolation +! point are computed as a convex combination of the response values +! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing +! that interpolation point. Therefore, if INTERP_OUT is present, then +! INTERP_IN must also be present. If both are omitted, only the +! simplices and convex combination weights are returned. +! +! EPS contains the real working precision for the problem on input. By default, +! EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff for the +! machine. In general, any values that differ by less than EPS are judged +! as equal, and any weights that are greater than -EPS are judged as +! nonnegative. EPS cannot take a value less than the default value of +! \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, the default +! value will be used instead automatically. +! +! EXTRAP contains the real maximum extrapolation distance (relative to the +! diameter of PTS) on input. Interpolation at a point outside the convex +! hull of PTS is done by projecting that point onto the convex hull, and +! then doing normal Delaunay interpolation at that projection. +! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) +! units outside the convex hull of PTS will not be done and an error code +! of 2 will be returned. Note that computing the projection can be +! expensive. Setting EXTRAP=0 will cause all extrapolation points to be +! ignored without ever computing a projection. By default, EXTRAP=0.1 +! (extrapolate by up to 10% of the diameter of PTS). +! +! RNORM(1:M) contains the real unscaled projection (2-norm) distances from +! any projection computations on output. If not present, these distances +! are still computed for each extrapolation point, but are never returned. +! +! IBUDGET on input contains the integer budget for performing flips while +! iterating toward the simplex containing each interpolation point in +! Q. This prevents DELAUNAYSPARSES from falling into an infinite loop when +! an inappropriate value of EPS is given with respect to the problem +! conditioning. By default, IBUDGET=50000. However, for extremely +! high-dimensional problems and pathological inputs, the default value +! may be insufficient. +! +! CHAIN is a logical input argument that determines whether a new first +! simplex should be constructed for each interpolation point +! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." +! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not +! recommended, unless the size of the triangulation is relatively small +! or the interpolation points are known to be tightly clustered. +! +! EXACT is a logical input argument that determines whether the exact +! diameter should be computed and whether a check for duplicate data +! points should be performed in advance. When EXACT=.FALSE., the +! diameter of PTS is approximated by twice the distance from the +! barycenter of PTS to the farthest point in PTS, and no check is +! done to find the closest pair of points, which could result in hard +! to find bugs later on. When EXACT=.TRUE., the exact diameter is +! computed and an error is returned whenever PTS contains duplicate +! values up to the precision EPS. By default EXACT=.TRUE., but setting +! EXACT=.FALSE. could result in significant speedup when N is large. +! It is strongly recommended that most users leave EXACT=.TRUE., as +! setting EXACT=.FALSE. could result in input errors that are difficult +! to identify. Also, the diameter approximation could be wrong by up to +! a factor of two. +! +! +! Subroutines and functions directly referenced from BLAS are +! DDOT, DGEMV, DNRM2, DTRSM, +! and from LAPACK are +! DGEQP3, DGETRF, DGETRS, DORMQR. +! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its +! SLATEC dependencies have been slightly edited to comply with the Fortran +! 2008 standard, with all print statements and references to stderr being +! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 +! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS +! Algorithm 777) is used for the real data type. The REAL_PRECISION module, +! DELAUNAYSPARSES, and DWNNLS and its dependencies comply with the Fortran +! 2008 standard. +! +! Primary Author: Tyler H. Chang +! Last Update: March, 2020 +! +USE REAL_PRECISION, ONLY : R8 +IMPLICIT NONE + +! Input arguments. +INTEGER, INTENT(IN) :: D, N +REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) ! Rescaled on output. +INTEGER, INTENT(IN) :: M +REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) ! Rescaled on output. +! Output arguments. +INTEGER, INTENT(OUT) :: SIMPS(:,:) +REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) +INTEGER, INTENT(OUT) :: IERR(:) +! Optional arguments. +REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) +REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) +REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP +REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) +INTEGER, INTENT(IN), OPTIONAL :: IBUDGET +LOGICAL, INTENT(IN), OPTIONAL :: CHAIN +LOGICAL, INTENT(IN), OPTIONAL :: EXACT + +! Local copies of optional input arguments. +REAL(KIND=R8) :: EPSL, EXTRAPL +INTEGER :: IBUDGETL +LOGICAL :: CHAINL, EXACTL + +! Local variables. +INTEGER :: I, J, K ! Loop iteration variables. +INTEGER :: IEXTRAPS ! Extrapolation budget. +INTEGER :: ITMP, JTMP ! Temporary variables for swapping, looping, etc. +INTEGER :: LWORK ! Size of the work array. +INTEGER :: MI ! Index of current interpolation point. +REAL(KIND=R8) :: CURRRAD ! Radius of the current circumsphere. +REAL(KIND=R8) :: MINRAD ! Minimum circumsphere radius observed. +REAL(KIND=R8) :: PTS_DIAM ! Scaled diameter of data set. +REAL(KIND=R8) :: PTS_SCALE ! Data scaling factor. +REAL(KIND=R8) :: RNORML ! Euclidean norm of the projection residual. +REAL(KIND=R8) :: SIDE1, SIDE2 ! Signs (+/-1) denoting sides of a facet. + +! Local arrays, requiring O(d^2) additional memory. +INTEGER :: IPIV(D) ! Pivot indices. +INTEGER :: SEED(D+1) ! Copy of the SEED simplex. Only used if CHAIN = .TRUE. +REAL(KIND=R8) :: AT(D,D) ! The transpose of A, the linear coefficient matrix. +REAL(KIND=R8) :: B(D) ! The RHS of a linear system. +REAL(KIND=R8) :: CENTER(D) ! The circumcenter of a simplex. +REAL(KIND=R8) :: LQ(D,D) ! Holds LU or QR factorization of AT. +REAL(KIND=R8) :: PLANE(D+1) ! The hyperplane containing a facet. +REAL(KIND=R8) :: PRGOPT_DWNNLS(1) ! Options array for DWNNLS. +REAL(KIND=R8) :: PROJ(D) ! The projection of the current iterate. +REAL(KIND=R8) :: TAU(D) ! Householder reflector constants. +REAL(KIND=R8) :: X(D) ! The solution to a linear system. + +! Extrapolation work arrays are only allocated if DWNNLS is called. +INTEGER, ALLOCATABLE :: IWORK_DWNNLS(:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: W_DWNNLS(:,:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: WORK(:) ! Allocated with size LWORK. +REAL(KIND=R8), ALLOCATABLE :: WORK_DWNNLS(:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: X_DWNNLS(:) ! Only for DWNNLS. + +! External functions and subroutines. +REAL(KIND=R8), EXTERNAL :: DDOT ! Inner product (BLAS). +REAL(KIND=R8), EXTERNAL :: DNRM2 ! Euclidean norm (BLAS). +EXTERNAL :: DGEMV ! General matrix vector multiply (BLAS) +EXTERNAL :: DGEQP3 ! Perform a QR factorization with column pivoting (LAPACK). +EXTERNAL :: DGETRF ! Perform a LU factorization with partial pivoting (LAPACK). +EXTERNAL :: DGETRS ! Use the output of DGETRF to solve a linear system (LAPACK). +EXTERNAL :: DORMQR ! Apply householder reflectors to a matrix (LAPACK). +EXTERNAL :: DTRSM ! Perform a triangular solve (BLAS). +EXTERNAL :: DWNNLS ! Solve an inequality constrained least squares problem + ! (SLATEC). + +! Check for input size and dimension errors. +IF (D < 1) THEN ! The dimension must satisfy D > 0. + IERR(:) = 10; RETURN; END IF +IF (N < D+1) THEN ! Must have at least D+1 data points. + IERR(:) = 11; RETURN; END IF +IF (M < 1) THEN ! Must have at least one interpolation point. + IERR(:) = 12; RETURN; END IF +IF (SIZE(PTS,1) .NE. D) THEN ! Dimension of PTS array should match. + IERR(:) = 13; RETURN; END IF +IF (SIZE(PTS,2) .NE. N) THEN ! Number of data points should match. + IERR(:) = 14; RETURN; END IF +IF (SIZE(Q,1) .NE. D) THEN ! Dimension of Q should match. + IERR(:) = 15; RETURN; END IF +IF (SIZE(Q,2) .NE. M) THEN ! Number of interpolation points should match. + IERR(:) = 16; RETURN; END IF +IF (SIZE(SIMPS,1) .NE. D+1) THEN ! Need space for D+1 vertices per simplex. + IERR(:) = 17; RETURN; END IF +IF (SIZE(SIMPS,2) .NE. M) THEN ! There will be M output simplices. + IERR(:) = 18; RETURN; END IF +IF (SIZE(WEIGHTS,1) .NE. D+1) THEN ! There will be D+1 weights per simplex. + IERR(:) = 19; RETURN; END IF +IF (SIZE(WEIGHTS,2) .NE. M) THEN ! One vector of weights per simplex. + IERR(:) = 20; RETURN; END IF +IF (SIZE(IERR) .NE. M) THEN ! An error flag for each interpolation point. + IERR(:) = 21; RETURN; END IF + +! Check for optional arguments. +IF (PRESENT(INTERP_IN) .NEQV. PRESENT(INTERP_OUT)) THEN + IERR(:) = 22; RETURN; END IF +IF (PRESENT(INTERP_IN)) THEN ! Sizes must agree. + IF (SIZE(INTERP_IN,1) .NE. SIZE(INTERP_OUT,1)) THEN + IERR(:) = 23 ; RETURN; END IF + IF(SIZE(INTERP_IN,2) .NE. N) THEN + IERR(:) = 24; RETURN; END IF + IF (SIZE(INTERP_OUT,2) .NE. M) THEN + IERR(:) = 25; RETURN; END IF + INTERP_OUT(:,:) = 0.0_R8 ! Initialize output to zeros. +END IF +EPSL = SQRT(EPSILON(0.0_R8)) ! Get the machine unit roundoff constant. +IF (PRESENT(EPS)) THEN + IF (EPSL < EPS) THEN ! If the given precision is too small, ignore it. + EPSL = EPS + END IF +END IF +IF (PRESENT(IBUDGET)) THEN + IBUDGETL = IBUDGET ! Use the given budget if present. + IF (IBUDGETL < 1) THEN + IERR(:) = 26; RETURN; END IF +ELSE + IBUDGETL = 50000 ! Default value for budget. +END IF +IF (PRESENT(EXTRAP)) THEN + EXTRAPL = EXTRAP + IF (EXTRAPL < 0) THEN ! Check that the extrapolation distance is legal. + IERR(:) = 27; RETURN; END IF +ELSE + EXTRAPL = 0.1_R8 ! Default extrapolation distance (for normalized points). +END IF +IF (PRESENT(RNORM)) THEN + IF (SIZE(RNORM,1) .NE. M) THEN ! The length of the array must match. + IERR(:) = 28; RETURN; END IF + RNORM(:) = 0.0_R8 ! Initialize output to zeros. +END IF +IF (PRESENT(CHAIN)) THEN + CHAINL = CHAIN ! Turn chaining on, if necessarry. + SEED(:) = 0 ! Initialize SEED in case it is needed. +ELSE + CHAINL = .FALSE. +END IF +IF (PRESENT(EXACT)) THEN + EXACTL = EXACT ! Set error checking and exact diameter computations. +ELSE + EXACTL = .TRUE. +END IF + +! Scale and center the data points and interpolation points. +CALL RESCALE(MINRAD, PTS_DIAM, PTS_SCALE) +IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. + IERR(:) = 30; RETURN; END IF + +! Query DGEQP3 for optimal work array size (LWORK). +LWORK = -1 +CALL DGEQP3(D,D,LQ,D,IPIV,TAU,B,LWORK,IERR(1)) +LWORK = INT(B(1)) ! Compute the optimal work array size. +ALLOCATE(WORK(LWORK), STAT=I) ! Allocate WORK to size LWORK. +IF (I .NE. 0) THEN ! Check for memory allocation errors. + IERR(:) = 50; RETURN; END IF + +! Initialize all error codes to "TBD" values. +IERR(:) = 40 + +! Outer loop over all interpolation points (in Q). +OUTER : DO MI = 1, M + + ! Check if this interpolation point was already found. + IF (IERR(MI) .EQ. 0) CYCLE OUTER + + ! Initialize the projection and reset the residual. + PROJ(:) = Q(:,MI) + RNORML = 0.0_R8 + + ! Check if extrapolation is enabled. + IF (EXTRAPL < EPSL) THEN + IEXTRAPS = -1 ! If not, set the extrapolation budget negative. + ELSE + IEXTRAPS = 1 ! Allow for exactly one projection for this point. + END IF + + ! If there is no useable seed or if chaining is turned off, then make a new + ! simplex. + IF( (.NOT. CHAINL) .OR. SEED(1) .EQ. 0) THEN + CALL MAKEFIRSTSIMP() + IF(IERR(MI) .NE. 0) CYCLE OUTER + ! Otherwise, use the seed. + ELSE + ! Copy the seed to the current simplex. + SIMPS(:,MI) = SEED(:) + ! Rebuild the linear system. + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + + ! Inner loop searching for a simplex containing the point Q(:,MI). + INNER : DO K = 1, IBUDGETL + + ! If chaining is on, save each good simplex as the next seed. + IF (CHAINL) SEED(:) = SIMPS(:,MI) + + ! Check if the current simplex contains Q(:,MI). + IF (PTINSIMP()) EXIT INNER + IF (IERR(MI) .NE. 0) CYCLE OUTER ! Check for an error flag. + + ! Swap out the least weighted vertex, but save its value in case it + ! needs to be restored later. + JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) + ITMP = SIMPS(JTMP,MI) + SIMPS(JTMP,MI) = SIMPS(D+1,MI) + + ! If the least weighted vertex (index JTMP) is not the first vertex, + ! then just drop row (JTMP-1) from the linear system (corresponding + ! to column (JTMP-1) of A^T). + IF(JTMP .NE. 1) THEN + AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) + ! However, if JTMP = 1, then both A^T and B must be reconstructed. + ELSE + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + + ! Compute the next simplex (do one flip). + CALL MAKESIMPLEX() + IF (IERR(MI) .NE. 0) CYCLE OUTER + + ! If no vertex was found, then this is an extrapolation point. + IF (SIMPS(D+1,MI) .EQ. 0) THEN + + ! If extrapolation is not allowed (EXTRAP=0), do not proceed. + IF (IEXTRAPS < 0) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! Set the error flag and skip this point. + IERR(MI) = 2; CYCLE OUTER + + ! If extrapolation is allowed (EXTRAP>0), check the budget. + ELSE IF (IEXTRAPS .EQ. 0) THEN + ! A second projection has been attempted. This code is rarely + ! called, except in extreme cases involving nearly singular + ! simplices near the convex hull of P. + + ! Swap the weights to match the simplex indices, and zero the + ! most negative weight. + WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) + WEIGHTS(D+1,MI) = 0.0_R8 + ! Loop through all the remaining facets from which Q(:,MI) is + ! visible, and attempt to flip across each one. + DO WHILE (SIMPS(D+1,MI) .EQ. 0) + ! Restore the previous simplex and linear system. + SIMPS(D+1,MI) = ITMP + AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + ! Find the next most negative weight. + JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) + ! Check if WEIGHTS(JTMP,MI) .GE. 0. + IF (WEIGHTS(JTMP,MI) .GE. -EPSL) THEN + ! There is no other direction to flip, so Q(:,MI) must be + ! within EPSL of the current simplex. + ! Project Q(:,MI) onto the current simplex. + + ! Since at least one projection has already been done, + ! the work arrays have already been allocated. + PRGOPT_DWNNLS(1) = 1.0_R8 + IWORK_DWNNLS(1) = 6*D + 6 + IWORK_DWNNLS(2) = 2*D + 2 + ! Set equality constraint. + W_DWNNLS(1,1:D+2) = 1.0_R8 + ! Populate LS coefficient matrix and RHS. + FORALL (I=1:D+1) W_DWNNLS(2:D+1,I) = PTS(:,SIMPS(I,MI)) + W_DWNNLS(2:D+1,D+2) = PROJ(:) + ! Project onto the current simplex. + CALL DWNNLS(W_DWNNLS, D+1, 1, D, D+1, 0, PRGOPT_DWNNLS, & + WEIGHTS(:,MI), WORK(1), IERR(MI), IWORK_DWNNLS, & + WORK_DWNNLS) + IF (IERR(MI) .EQ. 1) THEN ! Failure to converge. + IERR(MI) = 71; CYCLE OUTER + ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. + IERR(MI) = 72; CYCLE OUTER + END IF + ! A solution has been found; return it. + EXIT INNER + END IF + ! Otherwise, swap the vertices. + ITMP = SIMPS(JTMP,MI) + SIMPS(JTMP,MI) = SIMPS(D+1,MI) + ! Swap the weights to match, and zero the most negative weight. + WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) + WEIGHTS(D+1,MI) = 0.0_R8 + ! If the least weighted vertex (index JTMP) is not the first + ! vertex, then just drop row (JTMP-1) from the linear system + ! (corresponding to column (JTMP-1) of A^T). + IF (JTMP .NE. 1) THEN + AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) + ! However, if JTMP=1, then both A^T and B must be reconstructed. + ELSE + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + ! Compute another simplex (try to flip again). + CALL MAKESIMPLEX(); IF (IERR(MI) .NE. 0) CYCLE OUTER + END DO + ! If the loop terminates, then a good direction was found. + ! Resume the visibility walk as normal. + CYCLE INNER + END IF + + ! Otherwise, project the extrapolation point onto the convex hull. + CALL PROJECT() + IF (IERR(MI) .NE. 0) CYCLE OUTER + + ! Check the value of RNORML for over-extrapolation. + IF (RNORML > EXTRAPL * PTS_DIAM) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! If present, record the unscaled RNORM output. + IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE + ! Set the error flag and skip this point. + IERR(MI) = 2; CYCLE OUTER + END IF + + ! Otherwise, restore the previous simplex and continue with the + ! projected value. + SIMPS(D+1,MI) = ITMP + AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + IEXTRAPS = IEXTRAPS - 1 ! Decrement the budget. + END IF + + ! End of inner loop for finding each interpolation point. + END DO INNER + + ! Check for budget violation conditions. + IF (K > IBUDGETL) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! Set the error flag and skip this point. + IERR(MI) = 60; CYCLE OUTER + END IF + + ! If the residual is nonzero, set the extrapolation flag. + IF (RNORML > EPSL) IERR(MI) = 1 + + ! If present, record the RNORM output. + IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE + +END DO OUTER ! End of outer loop over all interpolation points. + +! If INTERP_IN and INTERP_OUT are present, compute all values f(q). +IF (PRESENT(INTERP_IN)) THEN + ! Loop over all interpolation points. + DO MI = 1, M + ! Check for errors. + IF (IERR(MI) .LE. 1) THEN + ! Compute the weighted sum of vertex response values. + DO K = 1, D+1 + INTERP_OUT(:,MI) = INTERP_OUT(:,MI) & + + INTERP_IN(:,SIMPS(K,MI)) * WEIGHTS(K,MI) + END DO + END IF + END DO +END IF + +! Free dynamic work arrays. +DEALLOCATE(WORK) +IF (ALLOCATED(IWORK_DWNNLS)) DEALLOCATE(IWORK_DWNNLS) +IF (ALLOCATED(WORK_DWNNLS)) DEALLOCATE(WORK_DWNNLS) +IF (ALLOCATED(W_DWNNLS)) DEALLOCATE(W_DWNNLS) +IF (ALLOCATED(X_DWNNLS)) DEALLOCATE(X_DWNNLS) + +RETURN + +CONTAINS ! Internal subroutines and functions. + +SUBROUTINE MAKEFIRSTSIMP() +! Iteratively construct the first simplex by choosing points that +! minimize the radius of the smallest circumball. Let P_1, P_2, ..., P_K +! denote the current set of vertices for the simplex. Let P* denote the +! candidate vertex to be added to the simplex. Let CENTER denote the +! circumcenter of the simplex. Then +! +! X = CENTER - P_1 +! +! is given by the minimum norm solution to the underdetermined linear system +! +! A X = B, where +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_K - P_1, P* - P_1 ] and +! B = [ /2, /2, ..., /2 ]^T. +! +! Then the radius of the smallest circumsphere is CURRRAD = \| X \|, +! and the next vertex is given by P_{K+1} = argmin_{P*} CURRRAD, where P* +! ranges over points in PTS that are not already a vertex of the simplex. +! +! On output, this subroutine fully populates the matrix A^T and vector B, +! and fills SIMPS(:,MI) with the indices of a valid Delaunay simplex. + +! Find the first point, i.e., the closest point to Q(:,MI). +SIMPS(:,MI) = 0 +MINRAD = HUGE(0.0_R8) +DO I = 1, N + ! Check the distance to Q(:,MI). + CURRRAD = DNRM2(D, PTS(:,I) - PROJ(:), 1) + IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(1,MI) = I; END IF +END DO +! Find the second point, i.e., the closest point to PTS(:,SIMPS(1,MI)). +MINRAD = HUGE(0.0_R8) +DO I = 1, N + ! Skip repeated vertices. + IF (I .EQ. SIMPS(1,MI)) CYCLE + ! Check the diameter of the resulting circumsphere. + CURRRAD = DNRM2(D, PTS(:,I)-PTS(:,SIMPS(1,MI)), 1) + IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(2,MI) = I; END IF +END DO +IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. + IERR(MI) = 30; RETURN; END IF +! Set up the first row of the linear system. +AT(:,1) = PTS(:,SIMPS(2,MI)) - PTS(:,SIMPS(1,MI)) +B(1) = DDOT(D, AT(:,1), 1, AT(:,1), 1) / 2.0_R8 +! Loop to collect the remaining D-1 vertices for the first simplex. +DO I = 2, D + ! For numerical stability, refactor A^T P = Q R for the next iteration. + LQ(:,1:I-1) = AT(:,1:I-1) + CALL DGEQP3(D, I-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 80; RETURN + END IF + ! Set the RHS to P^T B. + FORALL (ITMP = 1:I-1) X(ITMP) = B(IPIV(ITMP)) + ! Solve R^T Q^T X = P^T B for Q^T X, and save for later. + CALL DTRSM('L', 'U', 'T', 'N', I-1, 1, 1.0_R8, LQ, D, X, D) + ! Make a copy for computing the current center. + CENTER(1:I-1) = X(1:I-1) + CENTER(I:D) = 0.0_R8 + ! Apply Q from the left. + CALL DORMQR('L', 'N', D, 1, I-1, LQ, D, TAU, CENTER, D, WORK, & + LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 83; RETURN + END IF + CENTER = CENTER + PTS(:,SIMPS(1,MI)) + ! Re-initialize the radius for each iteration. + MINRAD = HUGE(0.0_R8) + ! Check each point P* in PTS. + DO J = 1, N + ! Check that this point is not already in the simplex. + IF (ANY(SIMPS(:,MI) .EQ. J)) CYCLE + ! If PTS(:,J) is more than twice MINRAD from CENTER, do a quick skip. + IF (DNRM2(D, CENTER - PTS(:,J), 1) > 2.0_R8 * MINRAD) CYCLE + ! Perform a rank-1 update to the current QR factorization of A^T by + ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI)) by Q^T and storing in the + ! final column of R. + LQ(:,I) = PTS(:,J) - PTS(:,SIMPS(1,MI)) + CALL DORMQR('L', 'T', D, 1, I-1, LQ(:,1:I-1), D, TAU, LQ(:,I), D, & + WORK, LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 83; RETURN + END IF + ! Implicitly apply the next Householder reflector. + LQ(I,I) = DNRM2(D+1-I, LQ(I:D,I), 1) + IF (LQ(I,I) < EPSL) THEN ! A is rank-deficient. + CYCLE ! If rank-deficient, skip this point. + END IF + ! Update the current radius by \| Q^T X \| = \| X \|. + WORK(1:I-1) = (LQ(1:I-1,I) / 2.0_R8) - X(1:I-1) + WORK(I) = LQ(I,I) / 2.0_R8 + X(I) = DDOT(I, LQ(1:I,I), 1, WORK(1:I), 1) / LQ(I,I) + CURRRAD = DNRM2(I, X(1:I), 1) + ! Compare the last component of Q^T X to the current minimum. + IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(I+1,MI) = J; END IF + END DO + ! Check that a point was found. If not, then all the points must lie in a + ! lower dimensional linear manifold (error case). + IF (SIMPS(I+1,MI) .EQ. 0) THEN; IERR(MI) = 31; RETURN; END IF + ! If all operations were successful, add the best P* to the linear system. + AT(:,I) = PTS(:,SIMPS(I+1,MI)) - PTS(:,SIMPS(1,MI)) + B(I) = DDOT(D, AT(:,I), 1, AT(:,I), 1) / 2.0_R8 +END DO +IERR(MI) = 0 ! Set error flag to 'success' for a normal return. +RETURN +END SUBROUTINE MAKEFIRSTSIMP + +SUBROUTINE MAKESIMPLEX() +! Given a Delaunay facet F whose containing hyperplane does not contain +! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' +! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F +! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the +! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly +! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing +! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices +! P_1, P_2, ..., P_D, P*. Then +! +! X = CENTER - P_1 +! +! is given by the solution to the nonsingular linear system +! +! A X = B where +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and +! B = [ /2, /2, ..., /2 ]^T. +! +! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the +! candidate P* that satisfies both of the following: +! +! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) +! must be on the same side of PLANE. +! +! 2) The circumball about CENTER must not contain any points in PTS in its +! interior (Delaunay property). +! +! The above are necessary and sufficient conditions for flipping the +! Delaunay simplex, given that F is indeed a Delaunay facet. +! +! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices +! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex +! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and +! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were +! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an +! extrapolation point (not a convex combination of points in PTS). + +! Compute the hyperplane PLANE. +CALL MAKEPLANE() +IF(IERR(MI) .NE. 0) RETURN ! Check for errors. +! Compute the sign for the side of PLANE containing Q(:,MI). +SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) +SIDE1 = SIGN(1.0_R8,SIDE1) +! Initialize the center, radius, and simplex. +SIMPS(D+1,MI) = 0 +CENTER(:) = 0.0_R8 +MINRAD = HUGE(0.0_R8) +! If D=1, just check for the closest point on SIDE1 of PTS(:,SIMPS(1,MI)). +IF (D .EQ. 1) THEN + ! Loop through all points P* in PTS. + DO I = 1, N + ! Check that P* is on the appropriate halfspace. + SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 + IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE + ! Check that P* is closer than the current solution. + IF (SIDE2 > MINRAD) CYCLE + ! Update the minimum distance and save the index I. + MINRAD = SIDE2 + SIMPS(2,MI) = I + END DO + IERR(MI) = 0 ! Reset the error flag to 'success' code. + ! Check for extrapolation condition. + IF(SIMPS(2,MI) .EQ. 0) RETURN + ! Add new point to the linear system. + AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) + B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 + RETURN +END IF +! Set the RHS to P^T B. +FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) +! Solve R^T Q^T X = P^T B for Q^T X. +CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) +! Loop through all points P* in PTS. +DO I = 1, N + ! Check that P* is inside the current ball. + IF (DNRM2(D, PTS(:,I) - CENTER(:), 1) > MINRAD) CYCLE ! If not, skip. + ! Check that P* is on the appropriate halfspace. + SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) + IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE ! If not, skip. + ! Perform a rank-1 update to the current QR factorization of A^T by + ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the + ! final column of R. + LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) + CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & + LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 83; RETURN + END IF + ! Update the last element of Q^T X. + WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) + WORK(D) = LQ(D,D) / 2.0_R8 + CENTER(1:D-1) = X(1:D-1) + CENTER(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) + ! Get the center by applying Q to the solution. + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER, D, WORK, LWORK, & + IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 83; RETURN + END IF + ! Update the new radius, center, and simplex. + MINRAD = DNRM2(D, CENTER, 1) + CENTER(:) = CENTER(:) + PTS(:,SIMPS(1,MI)) + SIMPS(D+1,MI) = I +END DO +IERR(MI) = 0 ! Reset the error flag to 'success' code. +! Check for extrapolation condition. +IF(SIMPS(D+1,MI) .EQ. 0) RETURN +! Add new point to the linear system. +AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) +B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 +RETURN +END SUBROUTINE MAKESIMPLEX + +SUBROUTINE MAKEPLANE() +! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed +! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. +! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal +! vector is any nonzero vector in ker A, where the matrix +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. +! +! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR +! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. +! Then the last column of Q is orthogonal to the range of A^T, and in ker A. +! +! Upon output, PLANE(1:D) contains the normal vector c and PLANE(D+1) +! contains \alpha defining the plane. Also, LQ, IPIV, and TAU define a QR +! factorizaton of the first D-1 columns of A^T. + +IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. + ! Compute the QR factorization. + IPIV=0 + LQ = AT + CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 80; RETURN + END IF + ! The nullspace is given by the last column of Q. + PLANE(1:D-1) = 0.0_R8 + PLANE(D) = 1.0_R8 + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & + LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 83; RETURN + END IF + ! Calculate the constant \alpha defining the plane. + PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) +ELSE ! Special case where D=1. + PLANE(1) = 1.0_R8 + PLANE(2) = PTS(1,SIMPS(1,MI)) +END IF +RETURN +END SUBROUTINE MAKEPLANE + +FUNCTION PTINSIMP() RESULT(TF) +! Determine if any interpolation points are in the current simplex, whose +! vertices P_1, P_2, ..., P_{D+1} are indexed by SIMPS(:,MI). These +! vertices determine a positive cone with generators V_I = P_{I+1} - P_1, +! I = 1, ..., D. For each interpolation point Q* in Q, Q* - P_1 can be +! expressed as a unique linear combination of the V_I. If all these linear +! weights are nonnegative and sum to less than or equal to 1.0, then Q* is +! in the simplex with vertices {P_I}_{I=1}^{D+1}. +! +! If any interpolation points in Q are contained in the simplex whose +! vertices are indexed by SIMPS(:,MI), then those points are marked as solved +! and the values of SIMPS and WEIGHTS are updated appropriately. On output, +! WEIGHTS(:,MI) contains the affine weights for producing Q(:,MI) as an +! affine combination of the points in PTS indexed by SIMPS(:,MI). If these +! weights are nonnegative, then PTINSIMP() returns TRUE. + +! Initialize the return value and local variables. +LOGICAL :: TF ! True/False value. +TF = .FALSE. + +! Compute the LU factorization of the matrix A^T, whose columns are +! P_{I+1} - P_1. +LQ = AT +CALL DGETRF(D, D, LQ, D, IPIV, IERR(MI)) +IF (IERR(MI) < 0) THEN ! LAPACK illegal input. + IERR(MI) = 81; RETURN +ELSE IF (IERR(MI) > 0) THEN ! Rank-deficiency detected. + IERR(MI) = 61; RETURN +END IF +! Solve A^T w = WORK to get the affine weights for Q(:,MI) or its projection. +WORK(1:D) = PROJ(:) - PTS(:,SIMPS(1,MI)) +CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(1:D), D, IERR(MI)) +IF (IERR(MI) < 0) THEN ! LAPACK illegal input. + IERR(MI) = 82; RETURN +END IF +WEIGHTS(2:D+1,MI) = WORK(1:D) +WEIGHTS(1,MI) = 1.0_R8 - SUM(WEIGHTS(2:D+1,MI)) +! Check if the weights for Q(:,MI) are nonnegative. +IF (ALL(WEIGHTS(:,MI) .GE. -EPSL)) TF = .TRUE. + +! Compute the affine weights for the rest of the interpolation points. +DO I = MI+1, M + ! Check that no solution has already been found. + IF (IERR(I) .NE. 40) CYCLE + ! Solve A^T w = WORK to get the affine weights for Q(:,I). + WORK(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) + CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(2:D+1), D, ITMP) + IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. + ! Check if the weights define a convex combination. + WORK(1) = 1.0_R8 - SUM(WORK(2:D+1)) + IF (ALL(WORK(1:D+1) .GE. -EPSL)) THEN + ! Copy the simplex indices and weights then flag as complete. + SIMPS(:,I) = SIMPS(:,MI) + WEIGHTS(:,I) = WORK(1:D+1) + IERR(I) = 0 + END IF +END DO +RETURN +END FUNCTION PTINSIMP + +SUBROUTINE PROJECT() +! Project a point outside the convex hull of the point set onto the convex hull +! by solving an inequality constrained least squares problem. The solution to +! the least squares problem gives the projection as a convex combination of the +! data points. The projection can then be computed by performing a matrix +! vector multiplication. + +! Allocate work arrays. +IF (.NOT. ALLOCATED(IWORK_DWNNLS)) THEN + ALLOCATE(IWORK_DWNNLS(D+1+N), STAT=IERR(MI)) + IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF +END IF +IF (.NOT. ALLOCATED(WORK_DWNNLS)) THEN + ALLOCATE(WORK_DWNNLS(D+1+N*5), STAT=IERR(MI)) + IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF +END IF +IF (.NOT. ALLOCATED(W_DWNNLS)) THEN + ALLOCATE(W_DWNNLS(D+1,N+1), STAT=IERR(MI)) + IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF +END IF +IF (.NOT. ALLOCATED(X_DWNNLS)) THEN + ALLOCATE(X_DWNNLS(N), STAT=IERR(MI)) + IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF +END IF + +! Initialize work array and settings values. +PRGOPT_DWNNLS(1) = 1.0_R8 +IWORK_DWNNLS(1) = D+1+5*N +IWORK_DWNNLS(2) = D+1+N +W_DWNNLS(1, :) = 1.0_R8 ! Set convexity (equality) constraint. +W_DWNNLS(2:D+1,1:N) = PTS(:,:) ! Copy data points. +W_DWNNLS(2:D+1,N+1) = PROJ(:) ! Copy extrapolation point. +! Compute the solution to the inequality constrained least squares problem to +! get the projection coefficients. +CALL DWNNLS(W_DWNNLS, D+1, 1, D, N, 0, PRGOPT_DWNNLS, X_DWNNLS, RNORML, & + IERR(MI), IWORK_DWNNLS, WORK_DWNNLS) +IF (IERR(MI) .EQ. 1) THEN ! Failure to converge. + IERR(MI) = 71; RETURN +ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. + IERR(MI) = 72; RETURN +END IF +! Zero all weights that are approximately zero and renormalize the sum. +WHERE (X_DWNNLS < EPSL) X_DWNNLS = 0.0_R8 +X_DWNNLS(:) = X_DWNNLS(:) / SUM(X_DWNNLS) +! Compute the actual projection via matrix vector multiplication. +CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) +RNORML = DNRM2(D, PROJ(:) - Q(:,MI), 1) +RETURN +END SUBROUTINE PROJECT + +SUBROUTINE RESCALE(MINDIST, DIAMETER, SCALE) +! Rescale and transform data to be centered at the origin with unit +! radius. This subroutine has O(n^2) complexity. +! +! On output, PTS and Q have been rescaled and shifted. All the data +! points in PTS are centered with unit radius, and the points in Q +! have been shifted and scaled in relation to PTS. +! +! MINDIST is a real number containing the (scaled) minimum distance +! between any two data points in PTS. +! +! DIAMETER is a real number containing the (scaled) diameter of the +! data set PTS. +! +! SCALE contains the real factor used to transform the data and +! interpolation points: scaled value = (original value - +! barycenter of data points)/SCALE. + +! Output arguments. +REAL(KIND=R8), INTENT(OUT) :: MINDIST, DIAMETER, SCALE + +! Local variables. +REAL(KIND=R8) :: PTS_CENTER(D) ! The center of the data points PTS. +REAL(KIND=R8) :: DISTANCE ! The current distance. + +! Initialize local values. +MINDIST = HUGE(0.0_R8) +DIAMETER = 0.0_R8 +SCALE = 0.0_R8 + +! Compute barycenter of all data points. +PTS_CENTER(:) = SUM(PTS(:,:), DIM=2)/REAL(N, KIND=R8) +! Center the points. +FORALL (I = 1:N) PTS(:,I) = PTS(:,I) - PTS_CENTER(:) +! Compute the scale factor (for unit radius). +DO I = 1, N ! Cycle through all points again. + DISTANCE = DNRM2(D, PTS(:,I), 1) ! Compute the distance from the center. + IF (DISTANCE > SCALE) THEN ! Compare to the current radius. + SCALE = DISTANCE + END IF +END DO +! Scale the points to unit radius. +PTS = PTS / SCALE +! Also transform Q similarly. +FORALL (I = 1:M) Q(:,I) = (Q(:,I) - PTS_CENTER(:)) / SCALE +! Compute the minimum and maximum distances. +IF (EXACTL) THEN + ! If exact error error checking is turned on, then compute the DIAMETER + ! and MINDIST values. + DO I = 1, N ! Cycle through all pairs of points. + DO J = I + 1, N + DISTANCE = DNRM2(D, PTS(:,I) - PTS(:,J), 1) ! Compute the distance. + IF (DISTANCE > DIAMETER) THEN ! Compare to the current diameter. + DIAMETER = DISTANCE + END IF + IF (DISTANCE < MINDIST) THEN ! Compare to the current minimum distance. + MINDIST = DISTANCE + END IF + END DO + END DO +ELSE + ! If exact error checking is turned off, then the diameter is approximately + ! 2.0 after rescaling and centering the points. The MINDIST is not computed. + DIAMETER = 2.0_R8 + MINDIST = 1.0_R8 +END IF +RETURN +END SUBROUTINE RESCALE + +END SUBROUTINE DELAUNAYSPARSES + + +SUBROUTINE DELAUNAYSPARSEP( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EXACT, & + PMODE ) +! This is a parallel implementation of an algorithm for efficiently performing +! interpolation in R^D via the Delaunay triangulation. The algorithm is fully +! described and analyzed in +! +! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. +! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate +! interpolation in arbitrary dimension via the Delaunay triangulation. In +! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, +! USA. Article 12, 8 pages. +! +! +! On input: +! +! D is the dimension of the space for PTS and Q. +! +! N is the number of data points in PTS. +! +! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the +! coordinates of a single data point in R^D. +! +! M is the number of interpolation points in Q. +! +! Q(1:D,1:M) is a real valued matrix with M columns, each containing the +! coordinates of a single interpolation point in R^D. +! +! +! On output: +! +! PTS and Q have been rescaled and shifted. All the data points in PTS +! are now contained in the unit hyperball in R^D, and the points in Q +! have been shifted and scaled accordingly in relation to PTS. +! +! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns +! in PTS) for the D+1 vertices of the Delaunay simplex containing each +! interpolation point in Q. +! +! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each +! point in Q as a convex combination of the D+1 corresponding vertices +! in SIMPS. +! +! IERR(1:M) contains integer valued error flags associated with the +! computation of each of the M interpolation points in Q. The error +! codes are: +! +! 00 : Succesful interpolation. +! 01 : Succesful extrapolation (up to the allowed extrapolation distance). +! 02 : This point was outside the allowed extrapolation distance; the +! corresponding entries in SIMPS and WEIGHTS contain zero values. +! +! 10 : The dimension D must be positive. +! 11 : Too few data points to construct a triangulation (i.e., N < D+1). +! 12 : No interpolation points given (i.e., M < 1). +! 13 : The first dimension of PTS does not agree with the dimension D. +! 14 : The second dimension of PTS does not agree with the number of points N. +! 15 : The first dimension of Q does not agree with the dimension D. +! 16 : The second dimension of Q does not agree with the number of +! interpolation points M. +! 17 : The first dimension of the output array SIMPS does not match the number +! of vertices needed for a D-simplex (D+1). +! 18 : The second dimension of the output array SIMPS does not match the +! number of interpolation points M. +! 19 : The first dimension of the output array WEIGHTS does not match the +! number of vertices for a a D-simplex (D+1). +! 20 : The second dimension of the output array WEIGHTS does not match the +! number of interpolation points M. +! 21 : The size of the error array IERR does not match the number of +! interpolation points M. +! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. +! 23 : The first dimension of INTERP_IN does not match the first +! dimension of INTERP_OUT. +! 24 : The second dimension of INTERP_IN does not match the number of +! data points PTS. +! 25 : The second dimension of INTERP_OUT does not match the number of +! interpolation points M. +! 26 : The budget supplied in IBUDGET does not contain a positive +! integer. +! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. +! 28 : The size of the RNORM output array does not match the number of +! interpolation points M. +! +! 30 : Two or more points in the data set PTS are too close together with +! respect to the working precision (EPS), which would result in a +! numerically degenerate simplex. +! 31 : All the data points in PTS lie in some lower dimensional linear +! manifold (up to the working precision), and no valid triangulation +! exists. +! 40 : An error caused DELAUNAYSPARSEP to terminate before this value could +! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may +! contain garbage values. +! +! 50 : A memory allocation error occurred while allocating the work array +! WORK. +! +! 60 : The budget was exceeded before the algorithm converged on this +! value. If the dimension is high, try increasing IBUDGET. This +! error can also be caused by a working precision EPS that is too +! small for the conditioning of the problem. +! +! 61 : A value that was judged appropriate later caused LAPACK to encounter a +! singularity. Try increasing the value of EPS. +! +! 70 : Allocation error for the extrapolation work arrays. +! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection +! of an extrapolation point onto the convex hull. +! 72 : The SLATEC subroutine DWNNLS has reported a usage error. +! +! The errors 72, 80--83 should never occur, and likely indicate a +! compiler bug or hardware failure. +! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. +! 81 : The LAPACK subroutine DGETRF has reported an illegal value. +! 82 : The LAPACK subroutine DGETRS has reported an illegal value. +! 83 : The LAPACK subroutine DORMQR has reported an illegal value. +! +! 90 : The value of PMODE is not valid. +! +! +! Optional arguments: +! +! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of +! the data points in PTS on input. The first dimension of INTERP_IN is +! inferred to be the dimension of these response vectors, and the +! second dimension must match N. If present, the response values will +! be computed for each interpolation point in Q, and stored in INTERP_OUT, +! which therefore must also be present. If both INTERP_IN and INTERP_OUT +! are omitted, only the containing simplices and convex combination +! weights are returned. +! +! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each +! interpolation point in Q on output. The first dimension of INTERP_OU +! must match the first dimension of INTERP_IN, and the second dimension +! must match M. If present, the response values at each interpolation +! point are computed as a convex combination of the response values +! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing +! that interpolation point. Therefore, if INTERP_OUT is present, then +! INTERP_IN must also be present. If both are omitted, only the +! simplices and convex combination weights are returned. +! +! EPS contains the real working precision for the problem on input. By +! default, EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff +! for the machine. In general, any values that differ by less than EPS +! are judged as equal, and any weights that are greater than -EPS are +! judged as nonnegative. EPS cannot take a value less than the default +! value of \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, +! the default value will be used instead automatically. +! +! EXTRAP contains the real maximum extrapolation distance (relative to the +! diameter of PTS) on input. Interpolation at a point outside the convex +! hull of PTS is done by projecting that point onto the convex hull, and +! then doing normal Delaunay interpolation at that projection. +! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) +! units outside the convex hull of PTS will not be done and an error code +! of 2 will be returned. Note that computing the projection can be +! expensive. Setting EXTRAP=0 will cause all extrapolation points to be +! ignored without ever computing a projection. By default, EXTRAP=0.1 +! (extrapolate by up to 10% of the diameter of PTS). +! +! RNORM(1:M) contains the real unscaled projection (2-norm) distances from +! any projection computations on output. If not present, these distances +! are still computed for each extrapolation point, but are never returned. +! +! IBUDGET on input contains the integer budget for performing flips while +! iterating toward the simplex containing each interpolation point in Q. +! This prevents DELAUNAYSPARSEP from falling into an infinite loop when +! an inappropriate value of EPS is given with respect to the problem +! conditioning. By default, IBUDGET=50000. However, for extremely +! high-dimensional problems and pathological inputs, the default value +! may be insufficient. +! +! CHAIN is a logical input argument that determines whether a new first +! simplex should be constructed for each interpolation point +! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." +! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not +! recommended, unless the size of the triangulation is relatively small +! or the interpolation points are known to be tightly clustered. +! +! EXACT is a logical input argument that determines whether the exact +! diameter should be computed and whether a check for duplicate data +! points should be performed in advance. When EXACT=.FALSE., the +! diameter of PTS is approximated by twice the distance from the +! barycenter of PTS to the farthest point in PTS, and no check is +! done to find the closest pair of points, which could result in hard +! to find bugs later on. When EXACT=.TRUE., the exact diameter is +! computed and an error is returned whenever PTS contains duplicate +! values up to the precision EPS. By default EXACT=.TRUE., but setting +! EXACT=.FALSE. could result in significant speedup when N is large. +! It is strongly recommended that most users leave EXACT=.TRUE., as +! setting EXACT=.FALSE. could result in input errors that are difficult +! to identify. Also, the diameter approximation could be wrong by up to +! a factor of two. +! +! PMODE is an integer specifying the level of parallelism to be exploited. +! If PMODE = 1, then parallelism is exploited at the level of the loop +! over all interpolation points (Level 1 parallelism). +! If PMODE = 2, then parallelism is exploited at the level of the loops +! over data points when constructing/flipping simplices (Level 2 +! parallelism). +! If PMODE = 3, then parallelism is exploited at both levels. Note: this +! implies that the total number of threads active at any time could be up +! to OMP_NUM_THREADS^2. +! By default, PMODE is set to 1 if there is more than 1 interpolation +! point and 2 otherwise. +! +! +! Subroutines and functions directly referenced from BLAS are +! DDOT, DGEMV, DNRM2, DTRSM, +! and from LAPACK are +! DGEQP3, DGETRF, DGETRS, DORMQR. +! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its +! SLATEC dependencies have been slightly edited to comply with the Fortran +! 2008 standard, with all print statements and references to stderr being +! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 +! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS +! Algorithm 777) is used for the real data type. The REAL_PRECISION module, +! DELAUNAYSPARSEP, and DWNNLS and its dependencies comply with the Fortran +! 2008 standard. +! +! Primary Author: Tyler H. Chang +! Last Update: March, 2020 +! +USE REAL_PRECISION, ONLY : R8 +IMPLICIT NONE + +! Input arguments. +INTEGER, INTENT(IN) :: D, N +REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) ! Rescaled on output. +INTEGER, INTENT(IN) :: M +REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) ! Rescaled on output. +! Output arguments. +INTEGER, INTENT(OUT) :: SIMPS(:,:) +REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) +INTEGER, INTENT(OUT) :: IERR(:) +! Optional arguments. +REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) +REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) +REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP +REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) +INTEGER, INTENT(IN), OPTIONAL :: IBUDGET, PMODE +LOGICAL, INTENT(IN), OPTIONAL :: CHAIN +LOGICAL, INTENT(IN), OPTIONAL :: EXACT + +! Local copies of optional input arguments. +REAL(KIND=R8) :: EPSL, EXTRAPL +INTEGER :: IBUDGETL +LOGICAL :: CHAINL, EXACTL, PLVL1, PLVL2 + +! Local variables. +LOGICAL :: PTINSIMP ! Tells if Q(:,MI) is in SIMPS(:,MI). +INTEGER :: I, J, K ! Loop iteration variables. +INTEGER :: IEXTRAPS ! Extrapolation budget. +INTEGER :: IERR_PRIV ! Private copy of the error flag. +INTEGER :: ITMP, JTMP ! Temporary variables for swapping, looping, etc. +INTEGER :: LWORK ! Size of the work array. +INTEGER :: MI ! Index of current interpolation point. +INTEGER :: VERTEX_PRIV ! Private copy of next vertex to add. +REAL(KIND=R8) :: CURRRAD ! Radius of the current circumsphere. +REAL(KIND=R8) :: MINRAD ! Minimum circumsphere radius observed. +REAL(KIND=R8) :: MINRAD_PRIV ! Private copy of MINRAD. +REAL(KIND=R8) :: PTS_DIAM ! Scaled diameter of data set. +REAL(KIND=R8) :: PTS_SCALE ! Data scaling factor. +REAL(KIND=R8) :: RNORML ! Euclidean norm of the projection residual. +REAL(KIND=R8) :: SIDE1, SIDE2 ! Signs (+/-1) denoting sides of a facet. + +! Local arrays, requiring O(d^2) additional memory. +INTEGER :: IPIV(D) ! Pivot indices. +INTEGER :: SEED(D+1) ! Copy of the SEED simplex. Only used if CHAIN = .TRUE. +REAL(KIND=R8) :: AT(D,D) ! The transpose of A, the linear coefficient matrix. +REAL(KIND=R8) :: B(D) ! The RHS of a linear system. +REAL(KIND=R8) :: CENTER(D) ! The circumcenter of a simplex. +REAL(KIND=R8) :: CENTER_PRIV(D) ! Private copy of CENTER. +REAL(KIND=R8) :: LQ(D,D) ! Holds LU or QR factorization of AT. +REAL(KIND=R8) :: PLANE(D+1) ! The hyperplane containing a facet. +REAL(KIND=R8) :: PRGOPT_DWNNLS(1) ! Options array for DWNNLS. +REAL(KIND=R8) :: PROJ(D) ! The projection of the current iterate. +REAL(KIND=R8) :: TAU(D) ! Householder reflector constants. +REAL(KIND=R8) :: X(D) ! The solution to a linear system. + +! Extrapolation work arrays are only allocated if DWNNLS is called. +INTEGER, ALLOCATABLE :: IWORK_DWNNLS(:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: W_DWNNLS(:,:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: WORK(:) ! Allocated with size LWORK. +REAL(KIND=R8), ALLOCATABLE :: WORK_DWNNLS(:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: X_DWNNLS(:) ! Only for DWNNLS. + +! External functions and subroutines. +REAL(KIND=R8), EXTERNAL :: DDOT ! Inner product (BLAS). +REAL(KIND=R8), EXTERNAL :: DNRM2 ! Euclidean norm (BLAS). +EXTERNAL :: DGEMV ! General matrix vector multiply (BLAS) +EXTERNAL :: DGEQP3 ! Perform a QR factorization with column pivoting (LAPACK). +EXTERNAL :: DGETRF ! Perform a LU factorization with partial pivoting (LAPACK). +EXTERNAL :: DGETRS ! Use the output of DGETRF to solve a linear system (LAPACK). +EXTERNAL :: DORMQR ! Apply householder reflectors to a matrix (LAPACK). +EXTERNAL :: DTRSM ! Perform a triangular solve (BLAS). +EXTERNAL :: DWNNLS ! Solve an inequality constrained least squares problem + ! (SLATEC). + +! Check for input size and dimension errors. +IF (D < 1) THEN ! The dimension must satisfy D > 0. + IERR(:) = 10; RETURN; END IF +IF (N < D+1) THEN ! Must have at least D+1 data points. + IERR(:) = 11; RETURN; END IF +IF (M < 1) THEN ! Must have at least one interpolation point. + IERR(:) = 12; RETURN; END IF +IF (SIZE(PTS,1) .NE. D) THEN ! Dimension of PTS array should match. + IERR(:) = 13; RETURN; END IF +IF (SIZE(PTS,2) .NE. N) THEN ! Number of data points should match. + IERR(:) = 14; RETURN; END IF +IF (SIZE(Q,1) .NE. D) THEN ! Dimension of Q should match. + IERR(:) = 15; RETURN; END IF +IF (SIZE(Q,2) .NE. M) THEN ! Number of interpolation points should match. + IERR(:) = 16; RETURN; END IF +IF (SIZE(SIMPS,1) .NE. D+1) THEN ! Need space for D+1 vertices per simplex. + IERR(:) = 17; RETURN; END IF +IF (SIZE(SIMPS,2) .NE. M) THEN ! There will be M output simplices. + IERR(:) = 18; RETURN; END IF +IF (SIZE(WEIGHTS,1) .NE. D+1) THEN ! There will be D+1 weights per simplex. + IERR(:) = 19; RETURN; END IF +IF (SIZE(WEIGHTS,2) .NE. M) THEN ! One vector of weights per simplex. + IERR(:) = 20; RETURN; END IF +IF (SIZE(IERR) .NE. M) THEN ! An error flag for each interpolation point. + IERR(:) = 21; RETURN; END IF + +! Check for optional arguments. +IF (PRESENT(INTERP_IN) .NEQV. PRESENT(INTERP_OUT)) THEN + IERR(:) = 22; RETURN; END IF +IF (PRESENT(INTERP_IN)) THEN ! Sizes must agree. + IF (SIZE(INTERP_IN,1) .NE. SIZE(INTERP_OUT,1)) THEN + IERR(:) = 23 ; RETURN; END IF + IF(SIZE(INTERP_IN,2) .NE. N) THEN + IERR(:) = 24; RETURN; END IF + IF (SIZE(INTERP_OUT,2) .NE. M) THEN + IERR(:) = 25; RETURN; END IF + INTERP_OUT(:,:) = 0.0_R8 ! Initialize output to zeros. +END IF +EPSL = SQRT(EPSILON(0.0_R8)) ! Get the machine unit roundoff constant. +IF (PRESENT(EPS)) THEN + IF (EPSL < EPS) THEN ! If the given precision is too small, ignore it. + EPSL = EPS + END IF +END IF +IF (PRESENT(IBUDGET)) THEN + IBUDGETL = IBUDGET ! Use the given budget if present. + IF (IBUDGETL < 1) THEN + IERR(:) = 26; RETURN; END IF +ELSE + IBUDGETL = 50000 ! Default value for budget. +END IF +IF (PRESENT(EXTRAP)) THEN + EXTRAPL = EXTRAP + IF (EXTRAPL < 0) THEN ! Check that the extrapolation distance is legal. + IERR(:) = 27; RETURN; END IF +ELSE + EXTRAPL = 0.1_R8 ! Default extrapolation distance (for normalized points). +END IF +IF (PRESENT(RNORM)) THEN + IF (SIZE(RNORM,1) .NE. M) THEN ! The length of the array must match. + IERR(:) = 28; RETURN; END IF + RNORM(:) = 0.0_R8 ! Initialize output to zeros. +END IF +IF (PRESENT(CHAIN)) THEN + CHAINL = CHAIN ! Turn chaining on, if necessarry. + SEED(:) = 0 ! Initialize SEED in case it is needed. +ELSE + CHAINL = .FALSE. +END IF +IF (PRESENT(EXACT)) THEN + EXACTL = EXACT ! Set error checking and exact diameter computations. +ELSE + EXACTL = .TRUE. +END IF +! Set the PMODE. +PLVL1 = .FALSE. +PLVL2 = .FALSE. +IF (PRESENT(PMODE)) THEN ! Check PMODE for legal values. + IF (PMODE .EQ. 1) THEN + PLVL1 = .TRUE. + ELSE IF (PMODE .EQ. 2) THEN + PLVL2 = .TRUE. + ELSE IF (PMODE .EQ. 3) THEN + PLVL1 = .TRUE.; PLVL2 = .TRUE. + ELSE + IERR(:) = 90; RETURN + END IF +ELSE ! The default setting for PMODE is level 1 parallelism if M > 1. + IF (M > 1) THEN + PLVL1 = .TRUE. + ELSE + PLVL2 = .TRUE. + END IF +END IF + +! Scale and center the data points and interpolation points. +CALL RESCALE(MINRAD, PTS_DIAM, PTS_SCALE) +IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. + IERR(:) = 30; RETURN; END IF + +! Query DGEQP3 for optimal work array size (LWORK). +LWORK = -1 +CALL DGEQP3(D,D,LQ,D,IPIV,TAU,B,LWORK,IERR(1)) +LWORK = INT(B(1)) ! Compute the optimal work array size. +ALLOCATE(WORK(LWORK), STAT=I) ! Allocate WORK to size LWORK. +IF (I .NE. 0) THEN ! Check for memory allocation errors. + IERR(:) = 50; RETURN; END IF + +! Initialize PRGOPT_DWNNLS in case of extrapolation. +PRGOPT_DWNNLS(1) = 1.0_R8 + +! Initialize all error codes to "TBD" values. +IERR(:) = 40 + +! Begin level 1 parallel region (over all interpolation points in Q). +!$OMP PARALLEL & +! +! The FIRSTPRIVATE list specifies initialized variables, of which each +! thread has a private copy. +!$OMP& FIRSTPRIVATE(SEED), & +! +! The PRIVATE list specifies uninitialized variables, of which each +! thread has a private copy. +!$OMP& PRIVATE(I, J, K, IEXTRAPS, ITMP, JTMP, CURRRAD, MI, MINRAD, & +!$OMP& RNORML, SIDE1, SIDE2, IERR_PRIV, VERTEX_PRIV, MINRAD_PRIV, & +!$OMP& PTINSIMP, IPIV, AT, B, CENTER, CENTER_PRIV, LQ, PLANE, & +!$OMP& PROJ, TAU, WORK, X, IWORK_DWNNLS, W_DWNNLS, WORK_DWNNLS, & +!$OMP& X_DWNNLS), & +! +! Any variables not explicitly listed above receive the SHARED scope +! by default and are visible across all threads. +!$OMP& DEFAULT(SHARED), & +! +!$OMP& IF(PLVL1) +!$OMP DO SCHEDULE(DYNAMIC) +OUTER : DO MI = 1, M + !$OMP CRITICAL(CHECK_IERR) + ! Check if this interpolation point was already found. + IF (IERR(MI) .EQ. 40) THEN + IERR(MI) = 0 + IERR_PRIV = 0 + ELSE + IERR_PRIV = -1 + END IF + !$OMP END CRITICAL(CHECK_IERR) + IF(IERR_PRIV .EQ. -1) CYCLE OUTER + + ! Initialize the projection and reset the residual. + PROJ(:) = Q(:,MI) + RNORML = 0.0_R8 + + ! Check if extrapolation is enabled. + IF (EXTRAPL < EPSL) THEN + IEXTRAPS = -1 ! If not, set the extrapolation budget negative. + ELSE + IEXTRAPS = 1 ! Allow for exactly one projection for this point. + END IF + + ! If there is no useable seed or if chaining is turned off, then make a new + ! simplex. + IF( (.NOT. CHAINL) .OR. SEED(1) .EQ. 0) THEN +! CALL MAKEFIRSTSIMP(); IF(IERR_PRIV .NE. 0) CYCLE OUTER + + +!****************************************************************************** +! Due to OpenMP's handling of variable scope, the parallel implementation of +! the subroutine MAKEFIRSTSIMP() has been in-lined here. +! +! SUBROUTINE MAKEFIRSTSIMP() +! +! Iteratively construct the first simplex by choosing points that +! minimize the radius of the smallest circumball. Let P_1, P_2, ..., P_K +! denote the current list of vertices for the simplex. Let P* denote the +! candidate vertex to be added to the simplex. Let CENTER denote the +! circumcenter of the simplex. Then +! +! X = CENTER - P_1 +! +! is given by the minimum norm solution to the underdetermined linear system +! +! A X = B, where +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_K - P_1, P* - P_1 ] and +! B = [ /2, /2, ..., /2 ]^T. +! +! Then the radius of the smallest circumsphere is CURRRAD = \| X \|, +! and the next vertex is given by P_{K+1} = argmin_{P*} CURRRAD, where P* +! ranges over points in PTS that are not already a vertex of the simplex. +! +! On output, this subroutine fully populates the matrix A^T and vector B, +! and fills SIMPS(:,MI) with the indices of a valid Delaunay simplex. + +! Initialize simplex and shared variables. +SIMPS(:,MI) = 0 +MINRAD_PRIV = HUGE(0.0_R8) +MINRAD = HUGE(0.0_R8) + +! Below is a Level 2 parallel region over N points in PTS to find the +! first and second vertices SIMPS(1,MI) and SIMPS(2,MI). +!$OMP PARALLEL & +! +! The FIRSTPRIVATE list specifies initialized variables, of which each +! thread has a private copy. +!$OMP& FIRSTPRIVATE(MINRAD_PRIV), & +! +! The PRIVATE list specifies uninitialized variables, of which each +! thread has a private copy. +!$OMP& PRIVATE(I, CURRRAD, VERTEX_PRIV), & +! +! Any variables not explicitly listed above receive the SHARED scope +! by default and are visible across all threads. +!$OMP& DEFAULT(SHARED), & +! +!$OMP& IF(PLVL2) +! Find the first point, i.e., the closest point to Q(:,MI). +!$OMP DO SCHEDULE(STATIC) +DO I = 1, N + ! Check the distance to Q(:,MI) + CURRRAD = DNRM2(D, PTS(:,I) - PROJ(:), 1) + IF (CURRRAD < MINRAD_PRIV) THEN + MINRAD_PRIV = CURRRAD; VERTEX_PRIV = I; + END IF +END DO +!$OMP END DO +!$OMP CRITICAL(REDUC_1) +IF (MINRAD_PRIV < MINRAD) THEN + MINRAD = MINRAD_PRIV; SIMPS(1,MI) = VERTEX_PRIV; +END IF +!$OMP END CRITICAL(REDUC_1) +! Find the second point, i.e., the closest point to PTS(:,SIMPS(1,MI)). +MINRAD_PRIV = HUGE(0.0_R8) +!$OMP BARRIER +!$OMP SINGLE +MINRAD = HUGE(0.0_R8) +!$OMP END SINGLE +!$OMP DO SCHEDULE(STATIC) +DO I = 1, N + ! Skip repeated vertices. + IF (I .EQ. SIMPS(1,MI)) CYCLE + ! Check the diameter of the resulting circumsphere. + CURRRAD = DNRM2(D, PTS(:,I)-PTS(:,SIMPS(1,MI)), 1) + IF (CURRRAD < MINRAD_PRIV) THEN + MINRAD_PRIV = CURRRAD; VERTEX_PRIV = I + END IF +END DO +!$OMP END DO +!$OMP CRITICAL(REDUC_2) +IF (MINRAD_PRIV < MINRAD) THEN + MINRAD = MINRAD_PRIV; SIMPS(2,MI) = VERTEX_PRIV +END IF +!$OMP END CRITICAL(REDUC_2) +!$OMP END PARALLEL +! This is the end of the Level 2 parallel block. +IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. + IERR(MI) = 30; CYCLE OUTER; END IF + +! Set up the first row of the system A X = B. +AT(:,1) = PTS(:,SIMPS(2,MI)) - PTS(:,SIMPS(1,MI)) +B(1) = DDOT(D, AT(:,1), 1, AT(:,1), 1) / 2.0_R8 + +! Loop to collect the remaining D-1 vertices for the first simplex. +DO I = 2, D + ! Compute A^T P = Q R for the current matrix A^T. + LQ(:,1:I-1) = AT(:,1:I-1) + CALL DGEQP3(D, I-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 80 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Set the RHS to P^T B. + FORALL (ITMP = 1:I-1) X(ITMP) = B(IPIV(ITMP)) + ! Solve R^T Q^T X = P^T B for Q^T X, and save for later. + CALL DTRSM('L', 'U', 'T', 'N', I-1, 1, 1.0_R8, LQ, D, X, D) + ! Make a copy for computing the current center. + CENTER(1:I-1) = X(1:I-1) + CENTER(I:D) = 0.0_R8 + ! Apply Q from the left. + CALL DORMQR('L', 'N', D, 1, I-1, LQ, D, TAU, CENTER, D, WORK, & + LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 83 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + CENTER = CENTER + PTS(:,SIMPS(1,MI)) + ! Re-initialize the radius for each iteration. + MINRAD = HUGE(0.0_R8) + MINRAD_PRIV = HUGE(0.0_R8) + VERTEX_PRIV = 0 + + ! This is another Level 2 parallel block over N points in PTS. + !$OMP PARALLEL & + ! + ! The FIRSTPRIVATE list specifies initialized variables, of which each + ! thread has a private copy. + !$OMP& FIRSTPRIVATE(LQ, MINRAD_PRIV, VERTEX_PRIV, X), & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(J, CURRRAD, WORK), & + ! + ! The REDUCTION clause specifies a PRIVATE variable that will retain + ! some value (i.e., max, min, sum, etc.) upon output. + !$OMP& REDUCTION(MAX:IERR_PRIV), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& IF(PLVL2) + + ! Initialize the error flag. + IERR_PRIV = 0 + !$OMP DO SCHEDULE(STATIC) + DO J = 1, N + IF (IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. + ! Check that this point is not already in the simplex. + IF (ANY(SIMPS(:,MI) .EQ. J)) CYCLE + ! If PTS(:,J) is more than twice MINRAD_PRIV from CENTER, do a quick skip. + IF (DNRM2(D, CENTER - PTS(:,J), 1) > 2.0_R8 * MINRAD_PRIV) CYCLE + ! Perform a rank-1 update to the current QR factorization of A^T by + ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the + ! final column of R. + LQ(:,I) = PTS(:,J) - PTS(:,SIMPS(1,MI)) + CALL DORMQR('L', 'T', D, 1, I-1, LQ(:,1:I-1), D, TAU, LQ(:,I), D, & + WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + IERR_PRIV = 83; CYCLE + END IF + ! Implicitly apply the next Householder reflector. + LQ(I,I) = DNRM2(D+1-I, LQ(I:D,I), 1) + IF (LQ(I,I) < EPSL) THEN ! A is rank-deficient. + CYCLE ! If rank-deficient, skip this point. + END IF + ! Update the current radius by \| Q^T X \| = \| X \|. + WORK(1:I-1) = (LQ(1:I-1,I) / 2.0_R8) - X(1:I-1) + WORK(I) = LQ(I,I) / 2.0_R8 + X(I) = DDOT(I, LQ(1:I,I), 1, WORK(1:I), 1) / LQ(I,I) + CURRRAD = DNRM2(I, X(1:I), 1) + ! Compare the last component of Q^T X to the current minimum. + IF (CURRRAD < MINRAD_PRIV) THEN + MINRAD_PRIV = CURRRAD; VERTEX_PRIV = J + END IF + END DO + !$OMP END DO + !$OMP CRITICAL(REDUC_3) + IF (MINRAD_PRIV < MINRAD) THEN + MINRAD = MINRAD_PRIV; SIMPS(I+1,MI) = VERTEX_PRIV + END IF + !$OMP END CRITICAL(REDUC_3) + !$OMP END PARALLEL + ! End of Level 2 parallel block. + + ! Check the final error flag. + IF (IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = IERR_PRIV + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Check that a point was found. If not, then all the points must lie in a + ! lower dimensional linear manifold (error case). + IF (SIMPS(I+1,MI) .EQ. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 31 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! If all operations were successful, add the best P* to the linear system. + AT(:,I) = PTS(:,SIMPS(I+1,MI)) - PTS(:,SIMPS(1,MI)) + B(I) = DDOT(D, AT(:,I), 1, AT(:,I), 1) / 2.0_R8 +END DO +! RETURN +! END SUBROUTINE MAKEFIRSTSIMP +! This marks the end of the in-lined MAKEFIRSTSIMP() subroutine call. +!****************************************************************************** + + + ! Otherwise, use the seed. + ELSE + ! Copy the seed to the current simplex. + SIMPS(:,MI) = SEED(:) + ! Rebuild the linear system. + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + + ! Inner loop searching for a simplex containing the point Q(:,MI). + INNER : DO K = 1, IBUDGETL + + ! If chaining is on, save each good simplex as the next seed. + IF (CHAINL) SEED(:) = SIMPS(:,MI) + + +!****************************************************************************** +! Due to OpenMP's handling of variable scope, the parallel implementation of +! the subroutine PTINSIMP() has been in-lined here. +! +! FUNCTION PTINSIMP() RESULT(TF) +! Determine if any interpolation points are in the current simplex, whose +! vertices (P_1, P_2, ..., P_{D+1}) are indexed by SIMPS(:,MI). These +! vertices determine a positive cone with generators V_I = P_{I+1} - P_1, +! I = 1, ..., D. For each interpolation point Q* in Q, Q* - P_1 can be +! expressed as a unique linear combination of the V_I. If all these linear +! weights are nonnegative and sum to less than or equal to 1.0, then Q* is +! in the simplex with vertices {P_I}_{I=1}^{D+1}. +! +! If any interpolation points in Q are contained in the simplex whose +! vertices are indexed by SIMPS(:,MI), then those points are marked as solved +! and the values of SIMPS and WEIGHTS are updated appropriately. On output, +! WEIGHTS(:,MI) contains the affine weights for producing Q(:,MI) as an +! affine combination of the points in PTS indexed by SIMPS(:,MI). If these +! weights are nonnegative, then PTINSIMP() returns TRUE. + +! Initialize the return value and local variables. +PTINSIMP = .FALSE. + +! Compute the LU factorization of the matrix A^T, whose columns are +! P_{I+1} - P_1. +LQ = AT +CALL DGETRF(D, D, LQ, D, IPIV, IERR_PRIV) +IF (IERR_PRIV < 0) THEN ! LAPACK illegal input. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 81 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER +ELSE IF (IERR_PRIV > 0) THEN ! Rank-deficiency detected. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 61 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER +END IF +! Solve A^T w = WORK to get the affine weights for Q(:,MI) or its projection. +WORK(1:D) = PROJ(:) - PTS(:,SIMPS(1,MI)) +CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(1:D), D, IERR_PRIV) +IF (IERR_PRIV < 0) THEN ! LAPACK illegal input. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 82 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER +END IF +WEIGHTS(2:D+1,MI) = WORK(1:D) +WEIGHTS(1,MI) = 1.0_R8 - SUM(WEIGHTS(2:D+1,MI)) +! Check if the weights for Q(:,MI) are nonnegative. +IF (ALL(WEIGHTS(:,MI) .GE. -EPSL)) PTINSIMP = .TRUE. + +! If Level 1 parallelism is active, do not parallelize this loop. +IF (PLVL1) THEN + ! Loop over all remaining unsolved interoplation points. Uses PLANE(:) + ! as a work array. + DO I = MI+1, M + ! Check that no solution has already been found. + !$OMP CRITICAL(CHECK_IERR) + ITMP = IERR(I) + !$OMP END CRITICAL(CHECK_IERR) + IF (ITMP .NE. 40) CYCLE + ! Solve A^T w = PLANE to get the affine weights for Q(:,I). + PLANE(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) + CALL DGETRS('N', D, 1, LQ, D, IPIV, PLANE(2:D+1), D, ITMP) + IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. + ! Check if the weights define a convex combination. + PLANE(1) = 1.0_R8 - SUM(PLANE(2:D+1)) + IF (ALL(PLANE(1:D+1) .GE. -EPSL)) THEN + !$OMP CRITICAL(CHECK_IERR) + IF(IERR(I) .EQ. 40) THEN + ! Copy the simplex indices and weights then flag as complete. + SIMPS(:,I) = SIMPS(:,MI) + WEIGHTS(:,I) = PLANE(1:D+1) + IERR(I) = 0 + END IF + !$OMP END CRITICAL(CHECK_IERR) + END IF + END DO +! If Level 1 parallelism is not active, there will be no conflicts for +! parallelizing this loop. +ELSE + ! Level 2 parallel block over all remaining unsolved interoplation + ! points. Uses PLANE(:) as a work array. + !$OMP PARALLEL DO & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(I, PLANE, ITMP), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& SCHEDULE(STATIC), & + !$OMP& IF(PLVL2) + DO I = MI+1, M + ! Check that no solution has already been found. + IF (IERR(I) .NE. 40) CYCLE + ! Solve A^T w = PLANE to get the affine weights for Q(:,I). + PLANE(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) + CALL DGETRS('N', D, 1, LQ, D, IPIV, PLANE(2:D+1), D, ITMP) + IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. + ! Check if the weights define a convex combination. + PLANE(1) = 1.0_R8 - SUM(PLANE(2:D+1)) + IF (ALL(PLANE(1:D+1) .GE. -EPSL)) THEN + ! Copy the simplex indices and weights then flag as complete. + SIMPS(:,I) = SIMPS(:,MI) + WEIGHTS(:,I) = PLANE(1:D+1) + IERR(I) = 0 + END IF + END DO + !$OMP END PARALLEL DO +END IF +! End of Level 2 parallel block. +! RETURN +! END FUNCTION PTINSIMP +! This marks the end of the in-lined PTINSIMP() subroutine call. +!****************************************************************************** + + + ! Check if the current simplex contains Q(:,MI). + IF (PTINSIMP) EXIT INNER + + ! Swap out the least weighted vertex, but save its value in case it + ! needs to be restored later. + JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) + ITMP = SIMPS(JTMP,MI) + SIMPS(JTMP,MI) = SIMPS(D+1,MI) + + ! If the least weighted vertex (index JTMP) is not the first vertex, + ! then just drop row (JTMP-1) from the linear system (corresponding + ! to column (JTMP-1) of A^T). + IF(JTMP .NE. 1) THEN + AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) + ! However, if JTMP = 1, then both A^T and B must be reconstructed. + ELSE + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + + ! Compute the next simplex (do one flip). +! CALL MAKESIMPLEX(); IF (IERR_PRIV .NE. 0) CYCLE OUTER + + +!****************************************************************************** +! Due to OpenMP's handling of variable scope, the parallel implementation of +! the subroutine MAKESIMPLEX() has been in-lined here. +! +! SUBROUTINE MAKESIMPLEX() +! Given a Delaunay facet F whose containing hyperplane does not contain +! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' +! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F +! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the +! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly +! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing +! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices +! P_1, P_2, ..., P_D, P*. Then +! +! X = CENTER - P_1 +! +! is given by the solution to the nonsingular linear system +! +! A X = B where +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and +! B = [ /2, /2, ..., /2 ]^T. +! +! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the +! candidate P* that satisfies both of the following: +! +! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) +! must be on the same side of PLANE. +! +! 2) The circumball about CENTER must not contain any points in PTS in its +! interior (Delaunay property). +! +! The above are necessary and sufficient conditions for flipping the +! Delaunay simplex, given that F is indeed a Delaunay facet. +! +! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices +! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex +! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and +! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were +! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an +! extrapolation point (not a convex combination of points in PTS). + +! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed +! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. +! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal +! vector is any nonzero vector in ker A, where the matrix +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. +! +! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR +! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. +! Then the last column of Q is orthogonal to the range of A^T, and in ker A. +IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. + ! Compute the QR factorization. + IPIV=0 + LQ = AT + CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 80 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! The nullspace is given by the last column of Q. + PLANE(1:D-1) = 0.0_R8 + PLANE(D) = 1.0_R8 + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & + LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 83 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Calculate the constant \alpha defining the plane. + PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) + ! Compute the sign for the side of PLANE containing Q(:,MI). + SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) + SIDE1 = SIGN(1.0_R8,SIDE1) + + ! Set the RHS to P^T B. + FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) + ! Solve R^T Q^T X = P^T B for Q^T X. + CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) + + ! Initialize the center, radius, simplex, and OpenMP variabls. + SIMPS(D+1,MI) = 0 + CENTER(:) = 0.0_R8 + CENTER_PRIV(:) = 0.0_R8 + MINRAD = HUGE(0.0_R8) + MINRAD_PRIV = HUGE(0.0_R8) + VERTEX_PRIV = 0 + + ! Begin Level 2 parallel loop over N points in PTS. + !$OMP PARALLEL & + ! + ! The FIRSTPRIVATE list specifies initialized variables, of which each + ! thread has a private copy. + !$OMP& FIRSTPRIVATE(CENTER_PRIV, LQ, MINRAD_PRIV, VERTEX_PRIV), & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(I, SIDE2, WORK), & + ! + ! The REDUCTION clause specifies a PRIVATE variable that will retain + ! some value (i.e., max, min, sum, etc.) upon output. + !$OMP& REDUCTION(MAX:IERR_PRIV), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& IF(PLVL2) + + ! Initialize the error flag. + IERR_PRIV = 0 + !$OMP DO SCHEDULE(STATIC) + DO I = 1, N + IF(IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. + ! Check that P* is inside the current ball. + IF (DNRM2(D, PTS(:,I) - CENTER_PRIV(:), 1) > MINRAD_PRIV) CYCLE + ! Check that P* is on the appropriate halfspace. + SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) + IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE + ! Perform a rank-1 update to the current QR factorization of A^T by + ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the + ! final column of R. + LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) + CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & + LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + IERR_PRIV = 83; CYCLE + END IF + ! Update the last element of Q^T X. + WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) + WORK(D) = LQ(D,D) / 2.0_R8 + CENTER_PRIV(1:D-1) = X(1:D-1) + CENTER_PRIV(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) + ! Get the center by applying Q to the solution. + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER_PRIV, D, & + WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + IERR_PRIV = 83; CYCLE + END IF + ! Update the new radius, center, and simplex. + MINRAD_PRIV = DNRM2(D, CENTER_PRIV, 1) + CENTER_PRIV(:) = CENTER_PRIV(:) + PTS(:,SIMPS(1,MI)) + VERTEX_PRIV = I + END DO + !$OMP END DO + !$OMP CRITICAL(REDUC_4) + ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. + IF (VERTEX_PRIV .NE. 0) THEN + IF (DNRM2(D, PTS(:,VERTEX_PRIV) - CENTER(:), 1) < MINRAD) THEN + MINRAD = MINRAD_PRIV + CENTER(:) = CENTER_PRIV(:) + SIMPS(D+1,MI) = VERTEX_PRIV + END IF + END IF + !$OMP END CRITICAL(REDUC_4) + !$OMP END PARALLEL + ! End level 2 parallel region. + + ! Check for error flags. + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = IERR_PRIV + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Check for extrapolation condition. + IF(SIMPS(D+1,MI) .NE. 0) THEN + ! Add new point to the linear system. + AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + END IF +ELSE ! Special case where D=1. + PLANE(1) = 1.0_R8 + PLANE(2) = PTS(1,SIMPS(1,MI)) + SIDE1 = SIGN(1.0_R8, PROJ(1) - PLANE(2)) + ! Initialize the radius, simplex, and OpenMP variabls. + SIMPS(2,MI) = 0 + MINRAD = HUGE(0.0_R8) + MINRAD_PRIV = HUGE(0.0_R8) + VERTEX_PRIV = 0 + ! Begin Level 2 parallel loop over N points in PTS. + !$OMP PARALLEL & + ! + ! The FIRSTPRIVATE list specifies initialized variables, of which each + ! thread has a private copy. + !$OMP& FIRSTPRIVATE(MINRAD_PRIV, VERTEX_PRIV), & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(I, SIDE2), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& IF(PLVL2) + + !$OMP DO SCHEDULE(STATIC) + DO I = 1, N + ! Check that P* is on the appropriate halfspace. + SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 + IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE + ! Check that P* is closer than the current solution. + IF (SIDE2 > MINRAD) CYCLE + ! Update the minimum distance and save the index I. + MINRAD_PRIV = SIDE2 + VERTEX_PRIV = I + END DO + !$OMP END DO + !$OMP CRITICAL(REDUC_4) + ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. + IF (VERTEX_PRIV .NE. 0) THEN + IF (MINRAD_PRIV < MINRAD) THEN + MINRAD = MINRAD_PRIV + SIMPS(2,MI) = VERTEX_PRIV + END IF + END IF + !$OMP END CRITICAL(REDUC_4) + !$OMP END PARALLEL + ! Check for extrapolation condition. + IF(SIMPS(2,MI) .NE. 0) THEN + ! Add new point to the linear system. + AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) + B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 + END IF +END IF +! RETURN +! END SUBROUTINE MAKESIMPLEX +! End of in-lined code for MAKESIMPLEX(). +!****************************************************************************** + + + ! If no vertex was found, then this is an extrapolation point. + IF (SIMPS(D+1,MI) .EQ. 0) THEN + ! If extrapolation is not allowed (EXTRAP=0), do not proceed. + IF (IEXTRAPS < 0) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! Set the error flag and skip this point. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 2 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + + ! If extrapolation is allowed (EXTRAP>0), check the budget. + ELSE IF (IEXTRAPS .EQ. 0) THEN + ! A second projection has been attempted. This code is rarely + ! called, except in extreme cases involving nearly singular + ! simplices near the convex hull of P. + + ! Swap the weights to match the simplex indices, and zero the + ! most negative weight. + !$OMP CRITICAL(CHECK_IERR) + WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) + WEIGHTS(D+1,MI) = 0.0_R8 + !$OMP END CRITICAL(CHECK_IERR) + ! Loop through all the remaining facets from which Q(:,MI) is + ! visible, and attempt to flip across each one. + DO WHILE (SIMPS(D+1,MI) .EQ. 0) + ! Restore the previous simplex and linear system. + SIMPS(D+1,MI) = ITMP + AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + ! Find the next most negative weight. + JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) + ! Check if WEIGHTS(JTMP,MI) .GE. 0. + IF (WEIGHTS(JTMP,MI) .GE. -EPSL) THEN + ! There is no other direction to flip, so Q(:,MI) must be + ! within EPSL of the current simplex. + ! Project Q(:,MI) onto the current simplex. + + ! Since at least one projection has already been done, + ! the work arrays have already been allocated. + PRGOPT_DWNNLS(1) = 1.0_R8 + IWORK_DWNNLS(1) = 6*D + 6 + IWORK_DWNNLS(2) = 2*D + 2 + ! Set equality constraint. + W_DWNNLS(1,1:D+2) = 1.0_R8 + ! Populate LS coefficient matrix and RHS. + FORALL (I=1:D+1) W_DWNNLS(2:D+1,I) = PTS(:,SIMPS(I,MI)) + W_DWNNLS(2:D+1,D+2) = PROJ(:) + ! Project onto the current simplex. + CALL DWNNLS(W_DWNNLS, D+1, 1, D, D+1, 0, PRGOPT_DWNNLS, & + WEIGHTS(:,MI), WORK(1), IERR_PRIV, IWORK_DWNNLS, & + WORK_DWNNLS) + IF (IERR_PRIV .EQ. 1) THEN ! Failure to converge. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 71 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + ELSE IF (IERR_PRIV .EQ. 2) THEN ! Illegal input detected. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 72 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! A solution has been found; return it. + EXIT INNER + END IF + ! Otherwise, swap the vertices. + ITMP = SIMPS(JTMP,MI) + SIMPS(JTMP,MI) = SIMPS(D+1,MI) + ! Swap the weights to match, and zero the most negative weight. + !$OMP CRITICAL(CHECK_IERR) + WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) + WEIGHTS(D+1,MI) = 0.0_R8 + !$OMP END CRITICAL(CHECK_IERR) + ! If the least weighted vertex (index JTMP) is not the first vertex, + ! then just drop row (JTMP-1) from the linear system + ! (corresponding to the JTMP-1st column of A^T). + IF (JTMP .NE. 1) THEN + AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) + ! However, if JTMP=1, then both A^T and B must be reconstructed. + ELSE + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + ! Compute another simplex (try to flip again). +! CALL MAKESIMPLEX(); IF (IERR(MI) .NE. 0) CYCLE OUTER + + +!****************************************************************************** +! Due to OpenMP's handling of variable scope, the parallel implementation of +! the subroutine MAKESIMPLEX() has been in-lined here. +! +! SUBROUTINE MAKESIMPLEX() +! Given a Delaunay facet F whose containing hyperplane does not contain +! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' +! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F +! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the +! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly +! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing +! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices +! P_1, P_2, ..., P_D, P*. Then +! +! X = CENTER - P_1 +! +! is given by the solution to the nonsingular linear system +! +! A X = B where +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and +! B = [ /2, /2, ..., /2 ]^T. +! +! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the +! candidate P* that satisfies both of the following: +! +! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) +! must be on the same side of PLANE. +! +! 2) The circumball about CENTER must not contain any points in PTS in its +! interior (Delaunay property). +! +! The above are necessary and sufficient conditions for flipping the +! Delaunay simplex, given that F is indeed a Delaunay facet. +! +! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices +! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex +! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and +! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were +! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an +! extrapolation point (not a convex combination of points in PTS). + +! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed +! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. +! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal +! vector is any nonzero vector in ker A, where the matrix +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. +! +! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR +! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. +! Then the last column of Q is orthogonal to the range of A^T, and in ker A. +IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. + ! Compute the QR factorization. + IPIV=0 + LQ = AT + CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 80 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! The nullspace is given by the last column of Q. + PLANE(1:D-1) = 0.0_R8 + PLANE(D) = 1.0_R8 + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & + LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 83 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Calculate the constant \alpha defining the plane. + PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) + ! Compute the sign for the side of PLANE containing Q(:,MI). + SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) + SIDE1 = SIGN(1.0_R8,SIDE1) + ! Set the RHS to P^T B. + FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) + ! Solve R^T Q^T X = P^T B for Q^T X. + CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) + ! Initialize the center, radius, simplex, and OpenMP variabls. + SIMPS(D+1,MI) = 0 + CENTER(:) = 0.0_R8 + CENTER_PRIV(:) = 0.0_R8 + MINRAD = HUGE(0.0_R8) + MINRAD_PRIV = HUGE(0.0_R8) + VERTEX_PRIV = 0 + + ! Begin Level 2 parallel loop over N points in PTS. + !$OMP PARALLEL & + ! + ! The FIRSTPRIVATE list specifies initialized variables, of which each + ! thread has a private copy. + !$OMP& FIRSTPRIVATE(CENTER_PRIV, LQ, MINRAD_PRIV, VERTEX_PRIV), & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(I, SIDE2, WORK), & + ! + ! The REDUCTION clause specifies a PRIVATE variable that will retain + ! some value (i.e., max, min, sum, etc.) upon output. + !$OMP& REDUCTION(MAX:IERR_PRIV), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& IF(PLVL2) + + ! Initialize the error flag. + IERR_PRIV = 0 + !$OMP DO SCHEDULE(STATIC) + DO I = 1, N + IF(IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. + ! Check that P* is inside the current ball. + IF (DNRM2(D, PTS(:,I) - CENTER_PRIV(:), 1) > MINRAD_PRIV) CYCLE + ! Check that P* is on the appropriate halfspace. + SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) + IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE + ! Perform a rank-1 update to the current QR factorization of A^T by + ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the + ! final column of R. + LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) + CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & + LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + IERR_PRIV = 83; CYCLE + END IF + ! Update the last element of Q^T X. + WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) + WORK(D) = LQ(D,D) / 2.0_R8 + CENTER_PRIV(1:D-1) = X(1:D-1) + CENTER_PRIV(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) + ! Get the center by applying Q to the solution. + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER_PRIV, D, & + WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + IERR_PRIV = 83; CYCLE + END IF + ! Update the new radius, center, and simplex. + MINRAD_PRIV = DNRM2(D, CENTER_PRIV, 1) + CENTER_PRIV(:) = CENTER_PRIV(:) + PTS(:,SIMPS(1,MI)) + VERTEX_PRIV = I + END DO + !$OMP END DO + !$OMP CRITICAL(REDUC_4) + ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. + IF (VERTEX_PRIV .NE. 0) THEN + IF (DNRM2(D, PTS(:,VERTEX_PRIV) - CENTER(:), 1) < MINRAD) THEN + MINRAD = MINRAD_PRIV + CENTER(:) = CENTER_PRIV(:) + SIMPS(D+1,MI) = VERTEX_PRIV + END IF + END IF + !$OMP END CRITICAL(REDUC_4) + !$OMP END PARALLEL + ! End level 2 parallel region. + + ! Check for error flags. + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = IERR_PRIV + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Check for extrapolation condition. + IF(SIMPS(D+1,MI) .NE. 0) THEN + ! Add new point to the linear system. + AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + END IF +ELSE ! Special case where D=1. + PLANE(1) = 1.0_R8 + PLANE(2) = PTS(1,SIMPS(1,MI)) + SIDE1 = SIGN(1.0_R8, PROJ(1) - PLANE(2)) + ! Initialize the radius, simplex, and OpenMP variabls. + SIMPS(2,MI) = 0 + MINRAD = HUGE(0.0_R8) + MINRAD_PRIV = HUGE(0.0_R8) + VERTEX_PRIV = 0 + ! Begin Level 2 parallel loop over N points in PTS. + !$OMP PARALLEL & + ! + ! The FIRSTPRIVATE list specifies initialized variables, of which each + ! thread has a private copy. + !$OMP& FIRSTPRIVATE(MINRAD_PRIV, VERTEX_PRIV), & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(I, SIDE2), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& IF(PLVL2) + + !$OMP DO SCHEDULE(STATIC) + DO I = 1, N + ! Check that P* is on the appropriate halfspace. + SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 + IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE + ! Check that P* is closer than the current solution. + IF (SIDE2 > MINRAD) CYCLE + ! Update the minimum distance and save the index I. + MINRAD_PRIV = SIDE2 + VERTEX_PRIV = I + END DO + !$OMP END DO + !$OMP CRITICAL(REDUC_4) + ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. + IF (VERTEX_PRIV .NE. 0) THEN + IF (MINRAD_PRIV < MINRAD) THEN + MINRAD = MINRAD_PRIV + SIMPS(2,MI) = VERTEX_PRIV + END IF + END IF + !$OMP END CRITICAL(REDUC_4) + !$OMP END PARALLEL + ! Check for extrapolation condition. + IF(SIMPS(2,MI) .NE. 0) THEN + ! Add new point to the linear system. + AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) + B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 + END IF +END IF +! RETURN +! END SUBROUTINE MAKESIMPLEX +! End of in-lined code for MAKESIMPLEX(). +!****************************************************************************** + + + END DO + ! If the loop terminates, then a good direction was found. + ! Resume the visibility walk as normal. + CYCLE INNER + END IF + + ! Otherwise, project the extrapolation point onto the convex hull. +! CALL PROJECT(); IF (IERR_PRIV .NE. 0) CYCLE OUTER + + +!****************************************************************************** +! Due to OpenMP's handling of variable scope, the parallel (identical to serial) +! implementation of the subroutine PROJECT() has been in-lined here. +! +! SUBROUTINE PROJECT() +! Project a point outside the convex hull of the point set onto the convex hull +! by solving an inequality constrained least squares problem. The solution to +! the least squares problem gives the projection as a convex combination of the +! data points. The projection can then be computed by performing a matrix +! vector multiplication. + +! Allocate work arrays. +IF (.NOT. ALLOCATED(IWORK_DWNNLS)) THEN + ALLOCATE(IWORK_DWNNLS(D+1+N), STAT=IERR_PRIV) + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 70 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF +END IF +IF (.NOT. ALLOCATED(WORK_DWNNLS)) THEN + ALLOCATE(WORK_DWNNLS(D+1+N*5), STAT=IERR_PRIV) + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 70 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF +END IF +IF (.NOT. ALLOCATED(W_DWNNLS)) THEN + ALLOCATE(W_DWNNLS(D+1,N+1), STAT=IERR_PRIV) + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 70 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF +END IF +IF (.NOT. ALLOCATED(X_DWNNLS)) THEN + ALLOCATE(X_DWNNLS(N), STAT=IERR_PRIV) + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 70 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF +END IF + +! Initialize work array and settings values. +IWORK_DWNNLS(1) = D+1+5*N +IWORK_DWNNLS(2) = D+1+N +W_DWNNLS(1, :) = 1.0_R8 ! Set convexity (equality) constraint. +W_DWNNLS(2:D+1,1:N) = PTS(:,:) ! Copy data points. +W_DWNNLS(2:D+1,N+1) = PROJ(:) ! Copy extrapolation point. +! Compute the solution to the inequality constrained least squares problem to +! get the projection coefficients. +CALL DWNNLS(W_DWNNLS, D+1, 1, D, N, 0, PRGOPT_DWNNLS, X_DWNNLS, RNORML, & + IERR_PRIV, IWORK_DWNNLS, WORK_DWNNLS) +IF (IERR_PRIV .EQ. 1) THEN ! Failure to converge. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 71 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER +ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 72 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER +END IF +! Compute the actual projection via matrix vector multiplication. +CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) +! Zero all weights that are approximately zero and renormalize the sum. +WHERE (X_DWNNLS < EPSL) X_DWNNLS = 0.0_R8 +X_DWNNLS(:) = X_DWNNLS(:) / SUM(X_DWNNLS) +! Compute the actual projection via matrix vector multiplication. +CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) +RNORML = DNRM2(D, PROJ(:) - Q(:,MI), 1) +! RETURN +! END SUBROUTINE PROJECT +! End of in-lined code for PROJECT(). +!****************************************************************************** + + + ! Check the value of RNORML for over-extrapolation. + IF (RNORML > EXTRAPL * PTS_DIAM) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! If present, record the unscaled RNORM output. + IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE + ! Set the error flag and skip this point. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 2 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + + ! Otherwise, restore the previous simplex and continue with the + ! projected value. + SIMPS(D+1,MI) = ITMP + AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + IEXTRAPS = IEXTRAPS - 1 ! Decrement the budget. + END IF + + ! End of inner loop for finding each interpolation point. + END DO INNER + + ! Check for budget violation conditions. + IF (K > IBUDGETL) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! Set the error flag and skip this point. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 60 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + + ! If the residual is nonzero, set the extrapolation flag. + IF (RNORML > EPSL) THEN + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 1 + !$OMP END CRITICAL(CHECK_IERR) + END IF + + ! If present, record the RNORM output. + IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE + +END DO OUTER ! End of outer loop over all interpolation points. +!$OMP END DO + +! If INTERP_IN and INTERP_OUT are present, compute all values f(q). +IF (PRESENT(INTERP_IN)) THEN + ! Level 1 parallel loop over all interpolation points. + !$OMP DO SCHEDULE(STATIC) + DO MI = 1, M + ! Check for errors. + IF (IERR(MI) .LE. 1) THEN + ! Compute the weighted sum of vertex response values. + DO K = 1, D+1 + INTERP_OUT(:,MI) = INTERP_OUT(:,MI) & + + INTERP_IN(:,SIMPS(K,MI)) * WEIGHTS(K,MI) + END DO + END IF + END DO + !$OMP END DO +END IF + +! Free optional work arrays. +IF (ALLOCATED(IWORK_DWNNLS)) DEALLOCATE(IWORK_DWNNLS) +IF (ALLOCATED(WORK_DWNNLS)) DEALLOCATE(WORK_DWNNLS) +IF (ALLOCATED(W_DWNNLS)) DEALLOCATE(W_DWNNLS) +IF (ALLOCATED(X_DWNNLS)) DEALLOCATE(X_DWNNLS) +!$OMP END PARALLEL +! End of Level 1 parallel region. + +! Free dynamic work arrays. +DEALLOCATE(WORK) + +RETURN + +CONTAINS ! Internal subroutines and functions. + +SUBROUTINE RESCALE(MINDIST, DIAMETER, SCALE) +! Rescale and transform data to be centered at the origin with unit +! radius. +! +! The parallel implementation of this subroutine exploits parallelism +! over loops of length N. For nested loops, this subroutine follows +! the OpenMP recommendation of a static schedule with a fixed chunk +! size (of 100). +! +! On output, PTS and Q have been rescaled and shifted. All the data +! points in PTS are centered with unit radius, and the points in Q +! have been shifted and scaled in relation to PTS. +! +! MINDIST is a real number containing the (scaled) minimum distance +! between any two data points in PTS. +! +! DIAMETER is a real number containing the (scaled) diameter of the +! data set PTS. +! +! SCALE contains the real factor used to transform the data and +! interpolation points: scaled value = (original value - +! barycenter of data points)/SCALE. + +! Output arguments. +REAL(KIND=R8), INTENT(OUT) :: MINDIST, DIAMETER, SCALE + +! Local variables. +REAL(KIND=R8) :: PTS_CENTER(D) ! The center of the data points PTS. +REAL(KIND=R8) :: DISTANCE ! The current distance. + +! Initialize local values. +MINDIST = HUGE(0.0_R8) +DIAMETER = 0.0_R8 +SCALE = 0.0_R8 + +! Compute barycenter of all data points. +PTS_CENTER(:) = SUM(PTS(:,:), DIM=2)/REAL(N, KIND=R8) +! Center the points. +FORALL (I = 1:N) PTS(:,I) = PTS(:,I) - PTS_CENTER(:) +! Compute the scale factor (for unit radius). +!$OMP PARALLEL DO & +!$OMP& PRIVATE(I, DISTANCE), & +!$OMP& REDUCTION(MAX:SCALE), & +!$OMP& SCHEDULE(STATIC), & +!$OMP& DEFAULT(SHARED) +DO I = 1, N ! Cycle through all points again. + DISTANCE = DNRM2(D, PTS(:,I), 1) ! Compute the distance from the center. + IF (DISTANCE > SCALE) THEN ! Compare to the current radius. + SCALE = DISTANCE + END IF +END DO +!$OMP END PARALLEL DO +! Scale the points to unit radius. +PTS = PTS / SCALE +! Also transform Q similarly. +FORALL (I = 1:M) Q(:,I) = (Q(:,I) - PTS_CENTER(:)) / SCALE +! Compute the minimum and maximum distances. +IF (EXACTL) THEN + ! If exact error error checking is turned on, then compute the DIAMETER + ! and MINDIST values. + !$OMP PARALLEL DO & + !$OMP& PRIVATE(I, DISTANCE), & + !$OMP& REDUCTION(MAX:DIAMETER), & + !$OMP& REDUCTION(MIN:MINDIST), & + !$OMP& SCHEDULE(STATIC, 100), & + !$OMP& DEFAULT(SHARED) + DO I = 1, N ! Cycle through all pairs of points. + DO J = I + 1, N + DISTANCE = DNRM2(D, PTS(:,I) - PTS(:,J), 1) ! Compute the distance. + IF (DISTANCE > DIAMETER) THEN ! Compare to the current diameter. + DIAMETER = DISTANCE + END IF + IF (DISTANCE < MINDIST) THEN ! Compare to the current minimum distance. + MINDIST = DISTANCE + END IF + END DO + END DO + !$OMP END PARALLEL DO +ELSE + ! If exact error checking is turned off, then the diameter is approximately + ! 2.0 after rescaling and centering the points. The MINDIST is not computed. + DIAMETER = 2.0_R8 + MINDIST = 1.0_R8 +END IF +RETURN +END SUBROUTINE RESCALE + +END SUBROUTINE DELAUNAYSPARSEP diff --git a/c_binding/delsparse.h b/c_binding/delsparse.h new file mode 100644 index 0000000..4ed0241 --- /dev/null +++ b/c_binding/delsparse.h @@ -0,0 +1,59 @@ +#ifndef DELSPARSEC +#define DELSPARSEC + +// serial subroutine: no optional arguments +extern void c_delaunaysparses(int *d, int *n, double pts[], int *m, double q[], + int simps[], double weights[], int ierr[]); + +// serial: compute interpolant values +extern void c_delaunaysparses_interp(int *d, int *n, double pts[], int *m, + double q[], int simps[], double weights[], + int ierr[], int *ir, double interp_in[], + double interp_out[]); + +// serial: optional arguments, no interpolant values +extern void c_delaunaysparses_opts(int *d, int *n, double pts[], int *m, + double q[],int simps[], double weights[], + int ierr[], double *eps, double *extrap, + double rnorm[], int *ibudget, bool *chain, + bool *exact); + +// serial: optional arguments and compute interpolant values +extern void c_delaunaysparses_interp_opts(int *d, int *n, double pts[], int *m, + double q[],int simps[], + double weights[], int ierr[], + int *ir, double interp_in[], + double interp_out[], double *eps, + double *extrap, double rnorm[], + int *ibudget, bool *chain, + bool *exact); + + +// parallel: no optional arguments +extern void c_delaunaysparsep(int *d, int *n, double pts[], int *m, double q[], + int simps[], double weights[], int ierr[]); + +// parallel: compute interpolant values +extern void c_delaunaysparsep_interp(int *d, int *n, double pts[], int *m, + double q[], int simps[], double weights[], + int ierr[], int *ir, double interp_in[], + double interp_out[]); + +// parallel: optional arguments, no interpolant values +extern void c_delaunaysparsep_opts(int *d, int *n, double pts[], int *m, + double q[],int simps[], double weights[], + int ierr[], double *eps, double *extrap, + double rnorm[], int *ibudget, bool *chain, + bool *exact, int *pmode); + +// parallel: optional arguments and compute interpolant values +extern void c_delaunaysparsep_interp_opts(int *d, int *n, double pts[], int *m, + double q[],int simps[], + double weights[], int ierr[], + int *ir, double interp_in[], + double interp_out[], double *eps, + double *extrap, double rnorm[], + int *ibudget, bool *chain, + bool *exact, int *pmode); + +#endif diff --git a/c_binding/delsparse_bind_c.f90 b/c_binding/delsparse_bind_c.f90 new file mode 100644 index 0000000..a1e5c78 --- /dev/null +++ b/c_binding/delsparse_bind_c.f90 @@ -0,0 +1,1265 @@ + + +SUBROUTINE C_DELAUNAYSPARSES_NOOPTS(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR) & + BIND(C, NAME="c_delaunaysparses") + ! This is a wrapper for DELAUNAYSPARSES with no optional arguments. + ! + ! + ! On input: + ! + ! D is the dimension of the space for PTS and Q. + ! + ! N is the number of data points in PTS. + ! + ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the + ! coordinates of a single data point in R^D. + ! + ! M is the number of interpolation points in Q. + ! + ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the + ! coordinates of a single interpolation point in R^D. + ! + ! + ! On output: + ! + ! PTS and Q have been rescaled and shifted. All the data points in PTS + ! are now contained in the unit hyperball in R^D, and the points in Q + ! have been shifted and scaled accordingly in relation to PTS. + ! + ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns + ! in PTS) for the D+1 vertices of the Delaunay simplex containing each + ! interpolation point in Q. + ! + ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each + ! point in Q as a convex combination of the D+1 corresponding vertices + ! in SIMPS. + ! + ! IERR(1:M) contains integer valued error flags associated with the + ! computation of each of the M interpolation points in Q. The error + ! codes are given in the definition of DELAUNAYSPARSES in delsparse.f90. + ! + ! + ! LAST UPDATE: + ! 11/2020 by THC + ! + USE REAL_PRECISION , ONLY : R8 + USE ISO_C_BINDING + + IMPLICIT NONE + + INTEGER(C_INT), INTENT(IN) :: D + INTEGER(C_INT), INTENT(IN) :: N + REAL(C_DOUBLE), INTENT(INOUT) :: PTS(D,N) + INTEGER(C_INT), INTENT(IN) :: M + REAL(C_DOUBLE), INTENT(INOUT) :: Q(D,M) + INTEGER(C_INT), INTENT(OUT) :: SIMPS(D+1,M) + REAL(C_DOUBLE), INTENT(OUT) :: WEIGHTS(D+1,M) + INTEGER(C_INT), INTENT(OUT) :: IERR(M) + + INTERFACE + SUBROUTINE DELAUNAYSPARSES(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, & + RNORM, IBUDGET, CHAIN, EXACT) + USE REAL_PRECISION , ONLY : R8 + IMPLICIT NONE + INTEGER, INTENT(IN) :: D + INTEGER, INTENT(IN) :: N + REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) + INTEGER, INTENT(IN) :: M + REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) + INTEGER, INTENT(OUT) :: SIMPS(:,:) + REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) + INTEGER, INTENT(OUT) :: IERR(:) + REAL(KIND=R8), INTENT(IN), OPTIONAL :: INTERP_IN(:,:) + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) + INTEGER, INTENT(IN), OPTIONAL :: IBUDGET + LOGICAL, INTENT(IN), OPTIONAL :: CHAIN + LOGICAL, INTENT(IN), OPTIONAL :: EXACT + END SUBROUTINE DELAUNAYSPARSES + END INTERFACE + + INTEGER :: D_LOC + INTEGER :: N_LOC + REAL(KIND=R8) :: PTS_LOC(D, N) + INTEGER :: M_LOC + REAL(KIND=R8) :: Q_LOC(D, M) + INTEGER :: SIMPS_LOC(D+1, M) + REAL(KIND=R8) :: WEIGHTS_LOC(D+1, M) + INTEGER :: IERR_LOC(M) + + D_LOC = INT(D) + N_LOC = INT(N) + PTS_LOC = REAL(PTS, KIND=R8) + M_LOC = INT(M) + Q_LOC = REAL(Q, KIND=R8) + + CALL DELAUNAYSPARSES(D_LOC, N_LOC, PTS_LOC, M_LOC, Q_LOC, SIMPS_LOC, & + WEIGHTS_LOC, IERR_LOC) + + PTS = REAL(PTS_LOC, KIND=C_DOUBLE) + Q = REAL(Q_LOC, KIND=C_DOUBLE) + SIMPS = INT(SIMPS_LOC, KIND=C_INT) + WEIGHTS = REAL(WEIGHTS_LOC, KIND=C_DOUBLE) + IERR = INT(IERR_LOC, KIND=C_INT) + + RETURN +END SUBROUTINE C_DELAUNAYSPARSES_NOOPTS + + +SUBROUTINE C_DELAUNAYSPARSES_INTERP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + IR, INTERP_IN, INTERP_OUT) & + BIND(C, NAME="c_delaunaysparses_interp") + ! This is a wrapper for DELAUNAYSPARSES with INTERP_IN and INTERP_OUT + ! specified, but no other optional arguments. Unlike the Fortran interface, + ! in this interface the dimension of the response variables (IR) must + ! be explicitly specified by an additional input, IR. + ! + ! + ! On input: + ! + ! D is the dimension of the space for PTS and Q. + ! + ! N is the number of data points in PTS. + ! + ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the + ! coordinates of a single data point in R^D. + ! + ! M is the number of interpolation points in Q. + ! + ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the + ! coordinates of a single interpolation point in R^D. + ! + ! IR is the dimension of the response variables. + ! + ! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of + ! the data points in PTS on input. The first dimension of INTERP_IN is + ! inferred to be the dimension of these response vectors, and the + ! second dimension must match N. + ! + ! + ! On output: + ! + ! PTS and Q have been rescaled and shifted. All the data points in PTS + ! are now contained in the unit hyperball in R^D, and the points in Q + ! have been shifted and scaled accordingly in relation to PTS. + ! + ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns + ! in PTS) for the D+1 vertices of the Delaunay simplex containing each + ! interpolation point in Q. + ! + ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each + ! point in Q as a convex combination of the D+1 corresponding vertices + ! in SIMPS. + ! + ! IERR(1:M) contains integer valued error flags associated with the + ! computation of each of the M interpolation points in Q. The error + ! codes are given in the definition of DELAUNAYSPARSES in delsparse.f90. + ! + ! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each + ! interpolation point in Q on output. The first dimension of INTERP_OU + ! must match the first dimension of INTERP_IN, and the second dimension + ! must match M. + ! + ! + ! LAST UPDATE: + ! 11/2020 by THC + ! + USE REAL_PRECISION , ONLY : R8 + USE ISO_C_BINDING + + IMPLICIT NONE + + INTEGER(C_INT), INTENT(IN) :: D + INTEGER(C_INT), INTENT(IN) :: N + REAL(C_DOUBLE), INTENT(INOUT) :: PTS(D,N) + INTEGER(C_INT), INTENT(IN) :: M + REAL(C_DOUBLE), INTENT(INOUT) :: Q(D,M) + INTEGER(C_INT), INTENT(OUT) :: SIMPS(D+1,M) + REAL(C_DOUBLE), INTENT(OUT) :: WEIGHTS(D+1,M) + INTEGER(C_INT), INTENT(OUT) :: IERR(M) + INTEGER(C_INT), INTENT(IN) :: IR + REAL(C_DOUBLE), INTENT(IN) :: INTERP_IN(IR, N) + REAL(C_DOUBLE), INTENT(OUT) :: INTERP_OUT(IR, M) + + INTERFACE + SUBROUTINE DELAUNAYSPARSES(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, & + RNORM, IBUDGET, CHAIN, EXACT) + USE REAL_PRECISION , ONLY : R8 + IMPLICIT NONE + INTEGER, INTENT(IN) :: D + INTEGER, INTENT(IN) :: N + REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) + INTEGER, INTENT(IN) :: M + REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) + INTEGER, INTENT(OUT) :: SIMPS(:,:) + REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) + INTEGER, INTENT(OUT) :: IERR(:) + REAL(KIND=R8), INTENT(IN), OPTIONAL :: INTERP_IN(:,:) + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) + INTEGER, INTENT(IN), OPTIONAL :: IBUDGET + LOGICAL, INTENT(IN), OPTIONAL :: CHAIN + LOGICAL, INTENT(IN), OPTIONAL :: EXACT + END SUBROUTINE DELAUNAYSPARSES + END INTERFACE + + INTEGER :: D_LOC + INTEGER :: N_LOC + REAL(KIND=R8) :: PTS_LOC(D, N) + INTEGER :: M_LOC + REAL(KIND=R8) :: Q_LOC(D, M) + INTEGER :: SIMPS_LOC(D+1, M) + REAL(KIND=R8) :: WEIGHTS_LOC(D+1, M) + INTEGER :: IERR_LOC(M) + REAL(KIND=R8) :: INTERP_IN_LOC(IR, N) + REAL(KIND=R8) :: INTERP_OUT_LOC(IR, M) + + D_LOC = INT(D) + N_LOC = INT(N) + PTS_LOC = REAL(PTS, KIND=R8) + M_LOC = INT(M) + Q_LOC = REAL(Q, KIND=R8) + INTERP_IN_LOC = REAL(INTERP_IN, KIND=R8) + + CALL DELAUNAYSPARSES(D_LOC, N_LOC, PTS_LOC, M_LOC, Q_LOC, SIMPS_LOC, & + WEIGHTS_LOC, IERR_LOC, INTERP_IN=INTERP_IN_LOC, & + INTERP_OUT=INTERP_OUT_LOC) + + PTS = REAL(PTS_LOC, KIND=C_DOUBLE) + Q = REAL(Q_LOC, KIND=C_DOUBLE) + SIMPS = INT(SIMPS_LOC, KIND=C_INT) + WEIGHTS = REAL(WEIGHTS_LOC, KIND=C_DOUBLE) + IERR = INT(IERR_LOC, KIND=C_INT) + INTERP_OUT = REAL(INTERP_OUT_LOC, KIND=C_DOUBLE) + + RETURN +END SUBROUTINE C_DELAUNAYSPARSES_INTERP + + +SUBROUTINE C_DELAUNAYSPARSES_OPTS(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, EPS, & + EXTRAP, RNORM, IBUDGET, CHAIN, EXACT) & + BIND(C, NAME="c_delaunaysparses_opts") + ! This is a wrapper for DELAUNAYSPARSES without INTERP_IN and INTERP_OUT, + ! but all other optional arguments present. + ! + ! + ! On input: + ! + ! D is the dimension of the space for PTS and Q. + ! + ! N is the number of data points in PTS. + ! + ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the + ! coordinates of a single data point in R^D. + ! + ! M is the number of interpolation points in Q. + ! + ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the + ! coordinates of a single interpolation point in R^D. + ! + ! EXTRAP contains the real maximum extrapolation distance (relative to the + ! diameter of PTS) on input. Interpolation at a point outside the convex + ! hull of PTS is done by projecting that point onto the convex hull, and + ! then doing normal Delaunay interpolation at that projection. + ! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) + ! units outside the convex hull of PTS will not be done and an error code + ! of 2 will be returned. Note that computing the projection can be + ! expensive. Setting EXTRAP=0 will cause all extrapolation points to be + ! ignored without ever computing a projection. + ! + ! IBUDGET on input contains the integer budget for performing flips while + ! iterating toward the simplex containing each interpolation point in Q. + ! This prevents DELAUNAYSPARSES from falling into an infinite loop when + ! an inappropriate value of EPS is given with respect to the problem + ! conditioning. For most cases, the default value of 50000 should be + ! more than sufficient. + ! + ! CHAIN is a logical input argument that determines whether a new first + ! simplex should be constructed for each interpolation point + ! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." + ! Setting CHAIN=.TRUE. is generally not recommended, unless the size of + ! the triangulation is relatively small or the interpolation points are + ! known to be tightly clustered. + ! + ! EXACT is a logical input argument that determines whether the exact + ! diameter should be computed and whether a check for duplicate data + ! points should be performed in advance. When EXACT=.FALSE., the + ! diameter of PTS is approximated by twice the distance from the + ! barycenter of PTS to the farthest point in PTS, and no check is + ! done to find the closest pair of points, which could result in hard + ! to find bugs later on. When EXACT=.TRUE., the exact diameter is + ! computed and an error is returned whenever PTS contains duplicate + ! values up to the precision EPS. Setting EXACT=.FALSE. could result + ! in significant speedup when N is large, but it is strongly + ! recommended that most users leave EXACT=.TRUE., as setting + ! EXACT=.FALSE. could result in input errors that are difficult + ! to identify. Also, the diameter approximation could be wrong by up + ! to a factor of two. + ! + ! + ! On output: + ! + ! PTS and Q have been rescaled and shifted. All the data points in PTS + ! are now contained in the unit hyperball in R^D, and the points in Q + ! have been shifted and scaled accordingly in relation to PTS. + ! + ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns + ! in PTS) for the D+1 vertices of the Delaunay simplex containing each + ! interpolation point in Q. + ! + ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each + ! point in Q as a convex combination of the D+1 corresponding vertices + ! in SIMPS. + ! + ! IERR(1:M) contains integer valued error flags associated with the + ! computation of each of the M interpolation points in Q. The error + ! codes are given in the definition of DELAUNAYSPARSES in delsparse.f90. + ! + ! RNORM(1:M) contains the real unscaled projection (2-norm) distances from + ! any projection computations on output. + ! + ! + ! LAST UPDATE: + ! 11/2020 by THC + ! + USE REAL_PRECISION , ONLY : R8 + USE ISO_C_BINDING + + IMPLICIT NONE + + INTEGER(C_INT), INTENT(IN) :: D + INTEGER(C_INT), INTENT(IN) :: N + REAL(C_DOUBLE), INTENT(INOUT) :: PTS(D,N) + INTEGER(C_INT), INTENT(IN) :: M + REAL(C_DOUBLE), INTENT(INOUT) :: Q(D,M) + INTEGER(C_INT), INTENT(OUT) :: SIMPS(D+1,M) + REAL(C_DOUBLE), INTENT(OUT) :: WEIGHTS(D+1,M) + INTEGER(C_INT), INTENT(OUT) :: IERR(M) + REAL(C_DOUBLE), INTENT(IN) :: EPS + REAL(C_DOUBLE), INTENT(IN) :: EXTRAP + REAL(C_DOUBLE), INTENT(OUT) :: RNORM(M) + INTEGER(C_INT), INTENT(IN) :: IBUDGET + LOGICAL(C_BOOL), INTENT(IN) :: CHAIN + LOGICAL(C_BOOL), INTENT(IN) :: EXACT + + INTERFACE + SUBROUTINE DELAUNAYSPARSES(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, & + RNORM, IBUDGET, CHAIN, EXACT) + USE REAL_PRECISION , ONLY : R8 + IMPLICIT NONE + INTEGER, INTENT(IN) :: D + INTEGER, INTENT(IN) :: N + REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) + INTEGER, INTENT(IN) :: M + REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) + INTEGER, INTENT(OUT) :: SIMPS(:,:) + REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) + INTEGER, INTENT(OUT) :: IERR(:) + REAL(KIND=R8), INTENT(IN), OPTIONAL :: INTERP_IN(:,:) + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) + INTEGER, INTENT(IN), OPTIONAL :: IBUDGET + LOGICAL, INTENT(IN), OPTIONAL :: CHAIN + LOGICAL, INTENT(IN), OPTIONAL :: EXACT + END SUBROUTINE DELAUNAYSPARSES + END INTERFACE + + INTEGER :: D_LOC + INTEGER :: N_LOC + REAL(KIND=R8) :: PTS_LOC(D, N) + INTEGER :: M_LOC + REAL(KIND=R8) :: Q_LOC(D, M) + INTEGER :: SIMPS_LOC(D+1, M) + REAL(KIND=R8) :: WEIGHTS_LOC(D+1, M) + INTEGER :: IERR_LOC(M) + REAL(KIND=R8) :: EPS_LOC + REAL(KIND=R8) :: EXTRAP_LOC + REAL(KIND=R8) :: RNORM_LOC(M) + INTEGER :: IBUDGET_LOC + LOGICAL :: CHAIN_LOC + LOGICAL :: EXACT_LOC + + D_LOC = INT(D) + N_LOC = INT(N) + PTS_LOC = REAL(PTS, KIND=R8) + M_LOC = INT(M) + Q_LOC = REAL(Q, KIND=R8) + EPS_LOC = REAL(EPS, KIND=R8) + EXTRAP_LOC = REAL(EXTRAP, KIND=R8) + IBUDGET_LOC = INT(IBUDGET) + CHAIN_LOC = LOGICAL(CHAIN) + EXACT_LOC = LOGICAL(EXACT) + + CALL DELAUNAYSPARSES(D_LOC, N_LOC, PTS_LOC, M_LOC, Q_LOC, SIMPS_LOC, & + WEIGHTS_LOC, IERR_LOC, EPS=EPS_LOC, & + EXTRAP=EXTRAP_LOC, RNORM=RNORM_LOC, & + IBUDGET=IBUDGET_LOC, CHAIN=CHAIN_LOC, & + EXACT=EXACT_LOC) + + PTS = REAL(PTS_LOC, KIND=C_DOUBLE) + Q = REAL(Q_LOC, KIND=C_DOUBLE) + SIMPS = INT(SIMPS_LOC, KIND=C_INT) + WEIGHTS = REAL(WEIGHTS_LOC, KIND=C_DOUBLE) + IERR = INT(IERR_LOC, KIND=C_INT) + RNORM = REAL(RNORM_LOC, KIND=C_DOUBLE) + + RETURN +END SUBROUTINE C_DELAUNAYSPARSES_OPTS + + +SUBROUTINE C_DELAUNAYSPARSES_INTERP_OPTS(D, N, PTS, M, Q, SIMPS, WEIGHTS, & + IERR, IR, INTERP_IN, INTERP_OUT, & + EPS, EXTRAP, RNORM, IBUDGET, CHAIN, & + EXACT, PMODE) & + BIND(C, NAME="c_delaunaysparses_interp_opts") + ! This is a wrapper for DELAUNAYSPARSES with all optional arguments present. + ! + ! + ! On input: + ! + ! D is the dimension of the space for PTS and Q. + ! + ! N is the number of data points in PTS. + ! + ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the + ! coordinates of a single data point in R^D. + ! + ! M is the number of interpolation points in Q. + ! + ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the + ! coordinates of a single interpolation point in R^D. + ! + ! IR is the dimension of the response variables. + ! + ! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of + ! the data points in PTS on input. The first dimension of INTERP_IN is + ! inferred to be the dimension of these response vectors, and the + ! second dimension must match N. + ! + ! EXTRAP contains the real maximum extrapolation distance (relative to the + ! diameter of PTS) on input. Interpolation at a point outside the convex + ! hull of PTS is done by projecting that point onto the convex hull, and + ! then doing normal Delaunay interpolation at that projection. + ! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) + ! units outside the convex hull of PTS will not be done and an error code + ! of 2 will be returned. Note that computing the projection can be + ! expensive. Setting EXTRAP=0 will cause all extrapolation points to be + ! ignored without ever computing a projection. + ! + ! IBUDGET on input contains the integer budget for performing flips while + ! iterating toward the simplex containing each interpolation point in Q. + ! This prevents DELAUNAYSPARSES from falling into an infinite loop when + ! an inappropriate value of EPS is given with respect to the problem + ! conditioning. For most cases, the default value of 50000 should be + ! more than sufficient. + ! + ! CHAIN is a logical input argument that determines whether a new first + ! simplex should be constructed for each interpolation point + ! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." + ! Setting CHAIN=.TRUE. is generally not recommended, unless the size of + ! the triangulation is relatively small or the interpolation points are + ! known to be tightly clustered. + ! + ! EXACT is a logical input argument that determines whether the exact + ! diameter should be computed and whether a check for duplicate data + ! points should be performed in advance. When EXACT=.FALSE., the + ! diameter of PTS is approximated by twice the distance from the + ! barycenter of PTS to the farthest point in PTS, and no check is + ! done to find the closest pair of points, which could result in hard + ! to find bugs later on. When EXACT=.TRUE., the exact diameter is + ! computed and an error is returned whenever PTS contains duplicate + ! values up to the precision EPS. Setting EXACT=.FALSE. could result + ! in significant speedup when N is large, but it is strongly + ! recommended that most users leave EXACT=.TRUE., as setting + ! EXACT=.FALSE. could result in input errors that are difficult + ! to identify. Also, the diameter approximation could be wrong by up + ! to a factor of two. + ! + ! PMODE is an integer specifying the level of parallelism to be exploited. + ! If PMODE = 1, then parallelism is exploited at the level of the loop + ! over all interpolation points (Level 1 parallelism). + ! If PMODE = 2, then parallelism is exploited at the level of the loops + ! over data points when constructing/flipping simplices (Level 2 + ! parallelism). + ! If PMODE = 3, then parallelism is exploited at both levels. Note: this + ! implies that the total number of threads active at any time could be up + ! to OMP_NUM_THREADS^2. + ! + ! + ! On output: + ! + ! PTS and Q have been rescaled and shifted. All the data points in PTS + ! are now contained in the unit hyperball in R^D, and the points in Q + ! have been shifted and scaled accordingly in relation to PTS. + ! + ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns + ! in PTS) for the D+1 vertices of the Delaunay simplex containing each + ! interpolation point in Q. + ! + ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each + ! point in Q as a convex combination of the D+1 corresponding vertices + ! in SIMPS. + ! + ! IERR(1:M) contains integer valued error flags associated with the + ! computation of each of the M interpolation points in Q. The error + ! codes are given in the definition of DELAUNAYSPARSES in delsparse.f90. + ! + ! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each + ! interpolation point in Q on output. The first dimension of INTERP_OUT + ! must match the first dimension of INTERP_IN, and the second dimension + ! must match M. + ! + ! RNORM(1:M) contains the real unscaled projection (2-norm) distances from + ! any projection computations on output. + ! + ! + ! LAST UPDATE: + ! 11/2020 by THC + ! + USE REAL_PRECISION , ONLY : R8 + USE ISO_C_BINDING + + IMPLICIT NONE + + INTEGER(C_INT), INTENT(IN) :: D + INTEGER(C_INT), INTENT(IN) :: N + REAL(C_DOUBLE), INTENT(INOUT) :: PTS(D,N) + INTEGER(C_INT), INTENT(IN) :: M + REAL(C_DOUBLE), INTENT(INOUT) :: Q(D,M) + INTEGER(C_INT), INTENT(OUT) :: SIMPS(D+1,M) + REAL(C_DOUBLE), INTENT(OUT) :: WEIGHTS(D+1,M) + INTEGER(C_INT), INTENT(OUT) :: IERR(M) + INTEGER(C_INT), INTENT(IN) :: IR + REAL(C_DOUBLE), INTENT(IN) :: INTERP_IN(IR, N) + REAL(C_DOUBLE), INTENT(OUT) :: INTERP_OUT(IR, M) + REAL(C_DOUBLE), INTENT(IN) :: EPS + REAL(C_DOUBLE), INTENT(IN) :: EXTRAP + REAL(C_DOUBLE), INTENT(OUT) :: RNORM(M) + INTEGER(C_INT), INTENT(IN) :: IBUDGET + LOGICAL(C_BOOL), INTENT(IN) :: CHAIN + LOGICAL(C_BOOL), INTENT(IN) :: EXACT + INTEGER(C_INT), INTENT(IN) :: PMODE + + INTERFACE + SUBROUTINE DELAUNAYSPARSES(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, & + RNORM, IBUDGET, CHAIN, EXACT) + USE REAL_PRECISION , ONLY : R8 + IMPLICIT NONE + INTEGER, INTENT(IN) :: D + INTEGER, INTENT(IN) :: N + REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) + INTEGER, INTENT(IN) :: M + REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) + INTEGER, INTENT(OUT) :: SIMPS(:,:) + REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) + INTEGER, INTENT(OUT) :: IERR(:) + REAL(KIND=R8), INTENT(IN), OPTIONAL :: INTERP_IN(:,:) + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) + INTEGER, INTENT(IN), OPTIONAL :: IBUDGET + LOGICAL, INTENT(IN), OPTIONAL :: CHAIN + LOGICAL, INTENT(IN), OPTIONAL :: EXACT + END SUBROUTINE DELAUNAYSPARSES + END INTERFACE + + INTEGER :: D_LOC + INTEGER :: N_LOC + REAL(KIND=R8) :: PTS_LOC(D, N) + INTEGER :: M_LOC + REAL(KIND=R8) :: Q_LOC(D, M) + INTEGER :: SIMPS_LOC(D+1, M) + REAL(KIND=R8) :: WEIGHTS_LOC(D+1, M) + INTEGER :: IERR_LOC(M) + REAL(KIND=R8) :: INTERP_IN_LOC(IR, N) + REAL(KIND=R8) :: INTERP_OUT_LOC(IR, M) + REAL(KIND=R8) :: EPS_LOC + REAL(KIND=R8) :: EXTRAP_LOC + REAL(KIND=R8) :: RNORM_LOC(M) + INTEGER :: IBUDGET_LOC + LOGICAL :: CHAIN_LOC + LOGICAL :: EXACT_LOC + INTEGER :: PMODE_LOC + + D_LOC = INT(D) + N_LOC = INT(N) + PTS_LOC = REAL(PTS, KIND=R8) + M_LOC = INT(M) + Q_LOC = REAL(Q, KIND=R8) + INTERP_IN_LOC = REAL(INTERP_IN, KIND=R8) + EPS_LOC = REAL(EPS, KIND=R8) + EXTRAP_LOC = REAL(EXTRAP, KIND=R8) + IBUDGET_LOC = INT(IBUDGET) + CHAIN_LOC = LOGICAL(CHAIN) + EXACT_LOC = LOGICAL(EXACT) + PMODE_LOC = INT(PMODE) + + CALL DELAUNAYSPARSES(D_LOC, N_LOC, PTS_LOC, M_LOC, Q_LOC, SIMPS_LOC, & + WEIGHTS_LOC, IERR_LOC, INTERP_IN=INTERP_IN_LOC, & + INTERP_OUT=INTERP_OUT_LOC, EPS=EPS_LOC, & + EXTRAP=EXTRAP_LOC, RNORM=RNORM_LOC, & + IBUDGET=IBUDGET_LOC, CHAIN=CHAIN_LOC, & + EXACT=EXACT_LOC) + + PTS = REAL(PTS_LOC, KIND=C_DOUBLE) + Q = REAL(Q_LOC, KIND=C_DOUBLE) + SIMPS = INT(SIMPS_LOC, KIND=C_INT) + WEIGHTS = REAL(WEIGHTS_LOC, KIND=C_DOUBLE) + IERR = INT(IERR_LOC, KIND=C_INT) + INTERP_OUT = REAL(INTERP_OUT_LOC, C_DOUBLE) + RNORM = REAL(RNORM_LOC, KIND=C_DOUBLE) + + RETURN +END SUBROUTINE C_DELAUNAYSPARSES_INTERP_OPTS + + +SUBROUTINE C_DELAUNAYSPARSEP_NOOPTS(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR) & + BIND(C, NAME="c_delaunaysparsep") + ! This is a wrapper for DELAUNAYSPARSEP with no optional arguments. + ! + ! + ! On input: + ! + ! D is the dimension of the space for PTS and Q. + ! + ! N is the number of data points in PTS. + ! + ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the + ! coordinates of a single data point in R^D. + ! + ! M is the number of interpolation points in Q. + ! + ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the + ! coordinates of a single interpolation point in R^D. + ! + ! + ! On output: + ! + ! PTS and Q have been rescaled and shifted. All the data points in PTS + ! are now contained in the unit hyperball in R^D, and the points in Q + ! have been shifted and scaled accordingly in relation to PTS. + ! + ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns + ! in PTS) for the D+1 vertices of the Delaunay simplex containing each + ! interpolation point in Q. + ! + ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each + ! point in Q as a convex combination of the D+1 corresponding vertices + ! in SIMPS. + ! + ! IERR(1:M) contains integer valued error flags associated with the + ! computation of each of the M interpolation points in Q. The error + ! codes are given in the definition of DELAUNAYSPARSEP in delsparse.f90. + ! + ! + ! LAST UPDATE: + ! 11/2020 by THC + ! + USE REAL_PRECISION , ONLY : R8 + USE ISO_C_BINDING + IMPLICIT NONE + + INTEGER(C_INT), INTENT(IN) :: D + INTEGER(C_INT), INTENT(IN) :: N + REAL(C_DOUBLE), INTENT(INOUT) :: PTS(D,N) + INTEGER(C_INT), INTENT(IN) :: M + REAL(C_DOUBLE), INTENT(INOUT) :: Q(D,M) + INTEGER(C_INT), INTENT(OUT) :: SIMPS(D+1,M) + REAL(C_DOUBLE), INTENT(OUT) :: WEIGHTS(D+1,M) + INTEGER(C_INT), INTENT(OUT) :: IERR(M) + + INTERFACE + SUBROUTINE DELAUNAYSPARSEP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, & + RNORM, IBUDGET, CHAIN, EXACT, PMODE) + USE REAL_PRECISION , ONLY : R8 + IMPLICIT NONE + INTEGER, INTENT(IN) :: D + INTEGER, INTENT(IN) :: N + REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) + INTEGER, INTENT(IN) :: M + REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) + INTEGER, INTENT(OUT) :: SIMPS(:,:) + REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) + INTEGER, INTENT(OUT) :: IERR(:) + REAL(KIND=R8), INTENT(IN), OPTIONAL :: INTERP_IN(:,:) + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) + INTEGER, INTENT(IN), OPTIONAL :: IBUDGET + LOGICAL, INTENT(IN), OPTIONAL :: CHAIN + LOGICAL, INTENT(IN), OPTIONAL :: EXACT + INTEGER, INTENT(IN), OPTIONAL :: PMODE + END SUBROUTINE DELAUNAYSPARSEP + END INTERFACE + + INTEGER :: D_LOC + INTEGER :: N_LOC + REAL(KIND=R8) :: PTS_LOC(D, N) + INTEGER :: M_LOC + REAL(KIND=R8) :: Q_LOC(D, M) + INTEGER :: SIMPS_LOC(D+1, M) + REAL(KIND=R8) :: WEIGHTS_LOC(D+1, M) + INTEGER :: IERR_LOC(M) + + D_LOC = INT(D) + N_LOC = INT(N) + PTS_LOC = REAL(PTS, KIND=R8) + M_LOC = INT(M) + Q_LOC = REAL(Q, KIND=R8) + + CALL DELAUNAYSPARSEP(D_LOC, N_LOC, PTS_LOC, M_LOC, Q_LOC, SIMPS_LOC, & + WEIGHTS_LOC, IERR_LOC) + + PTS = REAL(PTS_LOC, KIND=C_DOUBLE) + Q = REAL(Q_LOC, KIND=C_DOUBLE) + SIMPS = INT(SIMPS_LOC, KIND=C_INT) + WEIGHTS = REAL(WEIGHTS_LOC, KIND=C_DOUBLE) + IERR = INT(IERR_LOC, KIND=C_INT) + + RETURN +END SUBROUTINE C_DELAUNAYSPARSEP_NOOPTS + + +SUBROUTINE C_DELAUNAYSPARSEP_INTERP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + IR, INTERP_IN, INTERP_OUT) & + BIND(C, NAME="c_delaunaysparsep_interp") + ! This is a wrapper for DELAUNAYSPARSEP with INTERP_IN and INTERP_OUT + ! specified, but no other optional arguments. Unlike the Fortran interface, + ! in this interface the dimension of the response variables (IR) must + ! be explicitly specified by an additional input, IR. + ! + ! + ! On input: + ! + ! D is the dimension of the space for PTS and Q. + ! + ! N is the number of data points in PTS. + ! + ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the + ! coordinates of a single data point in R^D. + ! + ! M is the number of interpolation points in Q. + ! + ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the + ! coordinates of a single interpolation point in R^D. + ! + ! IR is the dimension of the response variables. + ! + ! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of + ! the data points in PTS on input. The first dimension of INTERP_IN is + ! inferred to be the dimension of these response vectors, and the + ! second dimension must match N. + ! + ! + ! On output: + ! + ! PTS and Q have been rescaled and shifted. All the data points in PTS + ! are now contained in the unit hyperball in R^D, and the points in Q + ! have been shifted and scaled accordingly in relation to PTS. + ! + ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns + ! in PTS) for the D+1 vertices of the Delaunay simplex containing each + ! interpolation point in Q. + ! + ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each + ! point in Q as a convex combination of the D+1 corresponding vertices + ! in SIMPS. + ! + ! IERR(1:M) contains integer valued error flags associated with the + ! computation of each of the M interpolation points in Q. The error + ! codes are given in the definition of DELAUNAYSPARSEP in delsparse.f90. + ! + ! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each + ! interpolation point in Q on output. The first dimension of INTERP_OU + ! must match the first dimension of INTERP_IN, and the second dimension + ! must match M. + ! + ! + ! LAST UPDATE: + ! 11/2020 by THC + ! + USE REAL_PRECISION , ONLY : R8 + USE ISO_C_BINDING + + IMPLICIT NONE + + INTEGER(C_INT), INTENT(IN) :: D + INTEGER(C_INT), INTENT(IN) :: N + REAL(C_DOUBLE), INTENT(INOUT) :: PTS(D,N) + INTEGER(C_INT), INTENT(IN) :: M + REAL(C_DOUBLE), INTENT(INOUT) :: Q(D,M) + INTEGER(C_INT), INTENT(OUT) :: SIMPS(D+1,M) + REAL(C_DOUBLE), INTENT(OUT) :: WEIGHTS(D+1,M) + INTEGER(C_INT), INTENT(OUT) :: IERR(M) + INTEGER(C_INT), INTENT(IN) :: IR + REAL(C_DOUBLE), INTENT(IN) :: INTERP_IN(IR, N) + REAL(C_DOUBLE), INTENT(OUT) :: INTERP_OUT(IR, M) + + INTERFACE + SUBROUTINE DELAUNAYSPARSEP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, & + RNORM, IBUDGET, CHAIN, EXACT, PMODE) + USE REAL_PRECISION , ONLY : R8 + IMPLICIT NONE + INTEGER, INTENT(IN) :: D + INTEGER, INTENT(IN) :: N + REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) + INTEGER, INTENT(IN) :: M + REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) + INTEGER, INTENT(OUT) :: SIMPS(:,:) + REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) + INTEGER, INTENT(OUT) :: IERR(:) + REAL(KIND=R8), INTENT(IN), OPTIONAL :: INTERP_IN(:,:) + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) + INTEGER, INTENT(IN), OPTIONAL :: IBUDGET + LOGICAL, INTENT(IN), OPTIONAL :: CHAIN + LOGICAL, INTENT(IN), OPTIONAL :: EXACT + INTEGER, INTENT(IN), OPTIONAL :: PMODE + END SUBROUTINE DELAUNAYSPARSEP + END INTERFACE + + INTEGER :: D_LOC + INTEGER :: N_LOC + REAL(KIND=R8) :: PTS_LOC(D, N) + INTEGER :: M_LOC + REAL(KIND=R8) :: Q_LOC(D, M) + INTEGER :: SIMPS_LOC(D+1, M) + REAL(KIND=R8) :: WEIGHTS_LOC(D+1, M) + INTEGER :: IERR_LOC(M) + REAL(KIND=R8) :: INTERP_IN_LOC(IR, N) + REAL(KIND=R8) :: INTERP_OUT_LOC(IR, M) + + D_LOC = INT(D) + N_LOC = INT(N) + PTS_LOC = REAL(PTS, KIND=R8) + M_LOC = INT(M) + Q_LOC = REAL(Q, KIND=R8) + INTERP_IN_LOC = REAL(INTERP_IN, KIND=R8) + + CALL DELAUNAYSPARSEP(D_LOC, N_LOC, PTS_LOC, M_LOC, Q_LOC, SIMPS_LOC, & + WEIGHTS_LOC, IERR_LOC, INTERP_IN=INTERP_IN_LOC, & + INTERP_OUT=INTERP_OUT_LOC) + + PTS = REAL(PTS_LOC, KIND=C_DOUBLE) + Q = REAL(Q_LOC, KIND=C_DOUBLE) + SIMPS = INT(SIMPS_LOC, KIND=C_INT) + WEIGHTS = REAL(WEIGHTS_LOC, KIND=C_DOUBLE) + IERR = INT(IERR_LOC, KIND=C_INT) + INTERP_OUT = REAL(INTERP_OUT_LOC, KIND=C_DOUBLE) + + RETURN +END SUBROUTINE C_DELAUNAYSPARSEP_INTERP + + +SUBROUTINE C_DELAUNAYSPARSEP_OPTS(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, EPS, & + EXTRAP, RNORM, IBUDGET, CHAIN, EXACT, PMODE) & + BIND(C, NAME="c_delaunaysparsep_opts") + ! This is a wrapper for DELAUNAYSPARSEP without INTERP_IN and INTERP_OUT, + ! but all other optional arguments present. + ! + ! + ! On input: + ! + ! D is the dimension of the space for PTS and Q. + ! + ! N is the number of data points in PTS. + ! + ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the + ! coordinates of a single data point in R^D. + ! + ! M is the number of interpolation points in Q. + ! + ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the + ! coordinates of a single interpolation point in R^D. + ! + ! EXTRAP contains the real maximum extrapolation distance (relative to the + ! diameter of PTS) on input. Interpolation at a point outside the convex + ! hull of PTS is done by projecting that point onto the convex hull, and + ! then doing normal Delaunay interpolation at that projection. + ! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) + ! units outside the convex hull of PTS will not be done and an error code + ! of 2 will be returned. Note that computing the projection can be + ! expensive. Setting EXTRAP=0 will cause all extrapolation points to be + ! ignored without ever computing a projection. + ! + ! IBUDGET on input contains the integer budget for performing flips while + ! iterating toward the simplex containing each interpolation point in Q. + ! This prevents DELAUNAYSPARSEP from falling into an infinite loop when + ! an inappropriate value of EPS is given with respect to the problem + ! conditioning. For most cases, the default value of 50000 should be + ! more than sufficient. + ! + ! CHAIN is a logical input argument that determines whether a new first + ! simplex should be constructed for each interpolation point + ! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." + ! Setting CHAIN=.TRUE. is generally not recommended, unless the size of + ! the triangulation is relatively small or the interpolation points are + ! known to be tightly clustered. + ! + ! EXACT is a logical input argument that determines whether the exact + ! diameter should be computed and whether a check for duplicate data + ! points should be performed in advance. When EXACT=.FALSE., the + ! diameter of PTS is approximated by twice the distance from the + ! barycenter of PTS to the farthest point in PTS, and no check is + ! done to find the closest pair of points, which could result in hard + ! to find bugs later on. When EXACT=.TRUE., the exact diameter is + ! computed and an error is returned whenever PTS contains duplicate + ! values up to the precision EPS. Setting EXACT=.FALSE. could result + ! in significant speedup when N is large, but it is strongly + ! recommended that most users leave EXACT=.TRUE., as setting + ! EXACT=.FALSE. could result in input errors that are difficult + ! to identify. Also, the diameter approximation could be wrong by up + ! to a factor of two. + ! + ! PMODE is an integer specifying the level of parallelism to be exploited. + ! If PMODE = 1, then parallelism is exploited at the level of the loop + ! over all interpolation points (Level 1 parallelism). + ! If PMODE = 2, then parallelism is exploited at the level of the loops + ! over data points when constructing/flipping simplices (Level 2 + ! parallelism). + ! If PMODE = 3, then parallelism is exploited at both levels. Note: this + ! implies that the total number of threads active at any time could be up + ! to OMP_NUM_THREADS^2. + ! + ! + ! On output: + ! + ! PTS and Q have been rescaled and shifted. All the data points in PTS + ! are now contained in the unit hyperball in R^D, and the points in Q + ! have been shifted and scaled accordingly in relation to PTS. + ! + ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns + ! in PTS) for the D+1 vertices of the Delaunay simplex containing each + ! interpolation point in Q. + ! + ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each + ! point in Q as a convex combination of the D+1 corresponding vertices + ! in SIMPS. + ! + ! IERR(1:M) contains integer valued error flags associated with the + ! computation of each of the M interpolation points in Q. The error + ! codes are given in the definition of DELAUNAYSPARSEP in delsparse.f90. + ! + ! RNORM(1:M) contains the real unscaled projection (2-norm) distances from + ! any projection computations on output. + ! + ! + ! LAST UPDATE: + ! 11/2020 by THC + ! + USE REAL_PRECISION , ONLY : R8 + USE ISO_C_BINDING + + IMPLICIT NONE + + INTEGER(C_INT), INTENT(IN) :: D + INTEGER(C_INT), INTENT(IN) :: N + REAL(C_DOUBLE), INTENT(INOUT) :: PTS(D,N) + INTEGER(C_INT), INTENT(IN) :: M + REAL(C_DOUBLE), INTENT(INOUT) :: Q(D,M) + INTEGER(C_INT), INTENT(OUT) :: SIMPS(D+1,M) + REAL(C_DOUBLE), INTENT(OUT) :: WEIGHTS(D+1,M) + INTEGER(C_INT), INTENT(OUT) :: IERR(M) + REAL(C_DOUBLE), INTENT(IN) :: EPS + REAL(C_DOUBLE), INTENT(IN) :: EXTRAP + REAL(C_DOUBLE), INTENT(OUT) :: RNORM(M) + INTEGER(C_INT), INTENT(IN) :: IBUDGET + LOGICAL(C_BOOL), INTENT(IN) :: CHAIN + LOGICAL(C_BOOL), INTENT(IN) :: EXACT + INTEGER(C_INT), INTENT(IN) :: PMODE + + INTERFACE + SUBROUTINE DELAUNAYSPARSEP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, & + RNORM, IBUDGET, CHAIN, EXACT, PMODE) + USE REAL_PRECISION , ONLY : R8 + IMPLICIT NONE + INTEGER, INTENT(IN) :: D + INTEGER, INTENT(IN) :: N + REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) + INTEGER, INTENT(IN) :: M + REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) + INTEGER, INTENT(OUT) :: SIMPS(:,:) + REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) + INTEGER, INTENT(OUT) :: IERR(:) + REAL(KIND=R8), INTENT(IN), OPTIONAL :: INTERP_IN(:,:) + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) + INTEGER, INTENT(IN), OPTIONAL :: IBUDGET + LOGICAL, INTENT(IN), OPTIONAL :: CHAIN + LOGICAL, INTENT(IN), OPTIONAL :: EXACT + INTEGER, INTENT(IN), OPTIONAL :: PMODE + END SUBROUTINE DELAUNAYSPARSEP + END INTERFACE + + INTEGER :: D_LOC + INTEGER :: N_LOC + REAL(KIND=R8) :: PTS_LOC(D, N) + INTEGER :: M_LOC + REAL(KIND=R8) :: Q_LOC(D, M) + INTEGER :: SIMPS_LOC(D+1, M) + REAL(KIND=R8) :: WEIGHTS_LOC(D+1, M) + INTEGER :: IERR_LOC(M) + REAL(KIND=R8) :: EPS_LOC + REAL(KIND=R8) :: EXTRAP_LOC + REAL(KIND=R8) :: RNORM_LOC(M) + INTEGER :: IBUDGET_LOC + LOGICAL :: CHAIN_LOC + LOGICAL :: EXACT_LOC + INTEGER :: PMODE_LOC + + D_LOC = INT(D) + N_LOC = INT(N) + PTS_LOC = REAL(PTS, KIND=R8) + M_LOC = INT(M) + Q_LOC = REAL(Q, KIND=R8) + EPS_LOC = REAL(EPS, KIND=R8) + EXTRAP_LOC = REAL(EXTRAP, KIND=R8) + IBUDGET_LOC = INT(IBUDGET) + CHAIN_LOC = LOGICAL(CHAIN) + EXACT_LOC = LOGICAL(EXACT) + PMODE_LOC = INT(PMODE) + + CALL DELAUNAYSPARSEP(D_LOC, N_LOC, PTS_LOC, M_LOC, Q_LOC, SIMPS_LOC, & + WEIGHTS_LOC, IERR_LOC, EPS=EPS_LOC, & + EXTRAP=EXTRAP_LOC, RNORM=RNORM_LOC, & + IBUDGET=IBUDGET_LOC, CHAIN=CHAIN_LOC, & + EXACT=EXACT_LOC, PMODE=PMODE_LOC) + + PTS = REAL(PTS_LOC, KIND=C_DOUBLE) + Q = REAL(Q_LOC, KIND=C_DOUBLE) + SIMPS = INT(SIMPS_LOC, KIND=C_INT) + WEIGHTS = REAL(WEIGHTS_LOC, KIND=C_DOUBLE) + IERR = INT(IERR_LOC, KIND=C_INT) + RNORM = REAL(RNORM_LOC, KIND=C_DOUBLE) + + RETURN +END SUBROUTINE C_DELAUNAYSPARSEP_OPTS + + +SUBROUTINE C_DELAUNAYSPARSEP_INTERP_OPTS(D, N, PTS, M, Q, SIMPS, WEIGHTS, & + IERR, IR, INTERP_IN, INTERP_OUT, & + EPS, EXTRAP, RNORM, IBUDGET, CHAIN, & + EXACT, PMODE) & + BIND(C, NAME="c_delaunaysparsep_interp_opts") + ! This is a wrapper for DELAUNAYSPARSEP with all optional arguments present. + ! + ! + ! On input: + ! + ! D is the dimension of the space for PTS and Q. + ! + ! N is the number of data points in PTS. + ! + ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the + ! coordinates of a single data point in R^D. + ! + ! M is the number of interpolation points in Q. + ! + ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the + ! coordinates of a single interpolation point in R^D. + ! + ! IR is the dimension of the response variables. + ! + ! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of + ! the data points in PTS on input. The first dimension of INTERP_IN is + ! inferred to be the dimension of these response vectors, and the + ! second dimension must match N. + ! + ! EXTRAP contains the real maximum extrapolation distance (relative to the + ! diameter of PTS) on input. Interpolation at a point outside the convex + ! hull of PTS is done by projecting that point onto the convex hull, and + ! then doing normal Delaunay interpolation at that projection. + ! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) + ! units outside the convex hull of PTS will not be done and an error code + ! of 2 will be returned. Note that computing the projection can be + ! expensive. Setting EXTRAP=0 will cause all extrapolation points to be + ! ignored without ever computing a projection. + ! + ! IBUDGET on input contains the integer budget for performing flips while + ! iterating toward the simplex containing each interpolation point in Q. + ! This prevents DELAUNAYSPARSEP from falling into an infinite loop when + ! an inappropriate value of EPS is given with respect to the problem + ! conditioning. For most cases, the default value of 50000 should be + ! more than sufficient. + ! + ! CHAIN is a logical input argument that determines whether a new first + ! simplex should be constructed for each interpolation point + ! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." + ! Setting CHAIN=.TRUE. is generally not recommended, unless the size of + ! the triangulation is relatively small or the interpolation points are + ! known to be tightly clustered. + ! + ! EXACT is a logical input argument that determines whether the exact + ! diameter should be computed and whether a check for duplicate data + ! points should be performed in advance. When EXACT=.FALSE., the + ! diameter of PTS is approximated by twice the distance from the + ! barycenter of PTS to the farthest point in PTS, and no check is + ! done to find the closest pair of points, which could result in hard + ! to find bugs later on. When EXACT=.TRUE., the exact diameter is + ! computed and an error is returned whenever PTS contains duplicate + ! values up to the precision EPS. Setting EXACT=.FALSE. could result + ! in significant speedup when N is large, but it is strongly + ! recommended that most users leave EXACT=.TRUE., as setting + ! EXACT=.FALSE. could result in input errors that are difficult + ! to identify. Also, the diameter approximation could be wrong by up + ! to a factor of two. + ! + ! PMODE is an integer specifying the level of parallelism to be exploited. + ! If PMODE = 1, then parallelism is exploited at the level of the loop + ! over all interpolation points (Level 1 parallelism). + ! If PMODE = 2, then parallelism is exploited at the level of the loops + ! over data points when constructing/flipping simplices (Level 2 + ! parallelism). + ! If PMODE = 3, then parallelism is exploited at both levels. Note: this + ! implies that the total number of threads active at any time could be up + ! to OMP_NUM_THREADS^2. + ! + ! + ! On output: + ! + ! PTS and Q have been rescaled and shifted. All the data points in PTS + ! are now contained in the unit hyperball in R^D, and the points in Q + ! have been shifted and scaled accordingly in relation to PTS. + ! + ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns + ! in PTS) for the D+1 vertices of the Delaunay simplex containing each + ! interpolation point in Q. + ! + ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each + ! point in Q as a convex combination of the D+1 corresponding vertices + ! in SIMPS. + ! + ! IERR(1:M) contains integer valued error flags associated with the + ! computation of each of the M interpolation points in Q. The error + ! codes are given in the definition of DELAUNAYSPARSEP in delsparse.f90. + ! + ! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each + ! interpolation point in Q on output. The first dimension of INTERP_OUT + ! must match the first dimension of INTERP_IN, and the second dimension + ! must match M. + ! + ! RNORM(1:M) contains the real unscaled projection (2-norm) distances from + ! any projection computations on output. + ! + ! + ! LAST UPDATE: + ! 11/2020 by THC + ! + USE REAL_PRECISION , ONLY : R8 + USE ISO_C_BINDING + + IMPLICIT NONE + + INTEGER(C_INT), INTENT(IN) :: D + INTEGER(C_INT), INTENT(IN) :: N + REAL(C_DOUBLE), INTENT(INOUT) :: PTS(D,N) + INTEGER(C_INT), INTENT(IN) :: M + REAL(C_DOUBLE), INTENT(INOUT) :: Q(D,M) + INTEGER(C_INT), INTENT(OUT) :: SIMPS(D+1,M) + REAL(C_DOUBLE), INTENT(OUT) :: WEIGHTS(D+1,M) + INTEGER(C_INT), INTENT(OUT) :: IERR(M) + INTEGER(C_INT), INTENT(IN) :: IR + REAL(C_DOUBLE), INTENT(IN) :: INTERP_IN(IR, N) + REAL(C_DOUBLE), INTENT(OUT) :: INTERP_OUT(IR, M) + REAL(C_DOUBLE), INTENT(IN) :: EPS + REAL(C_DOUBLE), INTENT(IN) :: EXTRAP + REAL(C_DOUBLE), INTENT(OUT) :: RNORM(M) + INTEGER(C_INT), INTENT(IN) :: IBUDGET + LOGICAL(C_BOOL), INTENT(IN) :: CHAIN + LOGICAL(C_BOOL), INTENT(IN) :: EXACT + INTEGER(C_INT), INTENT(IN) :: PMODE + + INTERFACE + SUBROUTINE DELAUNAYSPARSEP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, & + RNORM, IBUDGET, CHAIN, EXACT, PMODE) + USE REAL_PRECISION , ONLY : R8 + IMPLICIT NONE + INTEGER, INTENT(IN) :: D + INTEGER, INTENT(IN) :: N + REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) + INTEGER, INTENT(IN) :: M + REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) + INTEGER, INTENT(OUT) :: SIMPS(:,:) + REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) + INTEGER, INTENT(OUT) :: IERR(:) + REAL(KIND=R8), INTENT(IN), OPTIONAL :: INTERP_IN(:,:) + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) + INTEGER, INTENT(IN), OPTIONAL :: IBUDGET + LOGICAL, INTENT(IN), OPTIONAL :: CHAIN + LOGICAL, INTENT(IN), OPTIONAL :: EXACT + INTEGER, INTENT(IN), OPTIONAL :: PMODE + END SUBROUTINE DELAUNAYSPARSEP + END INTERFACE + + INTEGER :: D_LOC + INTEGER :: N_LOC + REAL(KIND=R8) :: PTS_LOC(D, N) + INTEGER :: M_LOC + REAL(KIND=R8) :: Q_LOC(D, M) + INTEGER :: SIMPS_LOC(D+1, M) + REAL(KIND=R8) :: WEIGHTS_LOC(D+1, M) + INTEGER :: IERR_LOC(M) + REAL(KIND=R8) :: INTERP_IN_LOC(IR, N) + REAL(KIND=R8) :: INTERP_OUT_LOC(IR, M) + REAL(KIND=R8) :: EPS_LOC + REAL(KIND=R8) :: EXTRAP_LOC + REAL(KIND=R8) :: RNORM_LOC(M) + INTEGER :: IBUDGET_LOC + LOGICAL :: CHAIN_LOC + LOGICAL :: EXACT_LOC + INTEGER :: PMODE_LOC + + D_LOC = INT(D) + N_LOC = INT(N) + PTS_LOC = REAL(PTS, KIND=R8) + M_LOC = INT(M) + Q_LOC = REAL(Q, KIND=R8) + INTERP_IN_LOC = REAL(INTERP_IN, KIND=R8) + EPS_LOC = REAL(EPS, KIND=R8) + EXTRAP_LOC = REAL(EXTRAP, KIND=R8) + IBUDGET_LOC = INT(IBUDGET) + CHAIN_LOC = LOGICAL(CHAIN) + EXACT_LOC = LOGICAL(EXACT) + PMODE_LOC = INT(PMODE) + + CALL DELAUNAYSPARSEP(D_LOC, N_LOC, PTS_LOC, M_LOC, Q_LOC, SIMPS_LOC, & + WEIGHTS_LOC, IERR_LOC, INTERP_IN=INTERP_IN_LOC, & + INTERP_OUT=INTERP_OUT_LOC, EPS=EPS_LOC, & + EXTRAP=EXTRAP_LOC, RNORM=RNORM_LOC, & + IBUDGET=IBUDGET_LOC, CHAIN=CHAIN_LOC, & + EXACT=EXACT_LOC, PMODE=PMODE_LOC) + + PTS = REAL(PTS_LOC, KIND=C_DOUBLE) + Q = REAL(Q_LOC, KIND=C_DOUBLE) + SIMPS = INT(SIMPS_LOC, KIND=C_INT) + WEIGHTS = REAL(WEIGHTS_LOC, KIND=C_DOUBLE) + IERR = INT(IERR_LOC, KIND=C_INT) + INTERP_OUT = REAL(INTERP_OUT_LOC, C_DOUBLE) + RNORM = REAL(RNORM_LOC, KIND=C_DOUBLE) + + RETURN +END SUBROUTINE C_DELAUNAYSPARSEP_INTERP_OPTS + diff --git a/c_binding/lapack.f b/c_binding/lapack.f new file mode 100644 index 0000000..3dff8b8 --- /dev/null +++ b/c_binding/lapack.f @@ -0,0 +1,4369 @@ + SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, +* -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER INB, INBMIN, IXOVER + PARAMETER( INB = 1, INBMIN = 2, IXOVER = 3 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, + $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN +* .. +* .. External Subroutines .. + EXTERNAL DGEQRF, DLAQP2, DLAQPS, DORMQR, DSWAP, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DNRM2 + EXTERNAL ILAENV, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE + IWS = 3*N + 1 + NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = 2*N + ( N + 1 )*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQP3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Move initial columns up front. +* + NFXD = 1 + DO 10 J = 1, N + IF( JPVT( J ).NE.0 ) THEN + IF( J.NE.NFXD ) THEN + CALL DSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 ) + JPVT( J ) = JPVT( NFXD ) + JPVT( NFXD ) = J + ELSE + JPVT( J ) = J + END IF + NFXD = NFXD + 1 + ELSE + JPVT( J ) = J + END IF + 10 CONTINUE + NFXD = NFXD - 1 +* +* Factorize fixed columns +* ======================= +* +* Compute the QR factorization of fixed columns and update +* remaining columns. +* + IF( NFXD.GT.0 ) THEN + NA = MIN( M, NFXD ) +*CC CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) + CALL DGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO ) + IWS = MAX( IWS, INT( WORK( 1 ) ) ) + IF( NA.LT.N ) THEN +*CC CALL DORM2R( 'LEFT', 'TRANSPOSE', M, N-NA, NA, A, LDA, +*CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) + CALL DORMQR( 'LEFT', 'TRANSPOSE', M, N-NA, NA, A, LDA, TAU, + $ A( 1, NA+1 ), LDA, WORK, LWORK, INFO ) + IWS = MAX( IWS, INT( WORK( 1 ) ) ) + END IF + END IF +* +* Factorize free columns +* ====================== +* + IF( NFXD.LT.MINMN ) THEN +* + SM = M - NFXD + SN = N - NFXD + SMINMN = MINMN - NFXD +* +* Determine the block size. +* + NB = ILAENV( INB, 'DGEQRF', ' ', SM, SN, -1, -1 ) + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked +* code. +* + NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', SM, SN, -1, + $ -1 ) ) +* +* + IF( NX.LT.SMINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + MINWS = 2*SN + ( SN+1 )*NB + IWS = MAX( IWS, MINWS ) + IF( LWORK.LT.MINWS ) THEN +* +* Not enough workspace to use optimal NB: Reduce NB and +* determine the minimum value of NB. +* + NB = ( LWORK-2*SN ) / ( SN+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', SM, N, + $ -1, -1 ) ) +* +* + END IF + END IF + END IF +* +* Initialize partial column norms. The first N elements of work +* store the exact column norms. +* + DO 20 J = NFXD + 1, N + WORK( J ) = DNRM2( SM, A( NFXD+1, J ), 1 ) + WORK( N+J ) = WORK( J ) + 20 CONTINUE +* + IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. + $ ( NX.LT.SMINMN ) ) THEN +* +* Use blocked code initially. +* + J = NFXD + 1 +* +* Compute factorization: while loop. +* +* + TOPBMN = MINMN - NX + 30 CONTINUE + IF( J.LE.TOPBMN ) THEN + JB = MIN( NB, TOPBMN-J+1 ) +* +* Factorize JB columns among columns J:N. +* + CALL DLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, + $ JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 ) +* + J = J + FJB + GO TO 30 + END IF + ELSE + J = NFXD + 1 + END IF +* +* Use unblocked code to factor the last or only block. +* +* + IF( J.LE.MINMN ) + $ CALL DLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), + $ TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ) ) +* + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of DGEQP3 +* + END + SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DGEQR2 computes a QR factorization of a real m by n matrix A: +* A = Q * R. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the m by n matrix A. +* On exit, the elements on and above the diagonal of the array +* contain the min(m,n) by n upper trapezoidal matrix R (R is +* upper triangular if m >= n); the elements below the diagonal, +* with the array TAU, represent the orthogonal matrix Q as a +* product of elementary reflectors (see Further Details). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) +* The scalar factors of the elementary reflectors (see Further +* Details). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further Details +* =============== +* +* The matrix Q is represented as a product of elementary reflectors +* +* Q = H(1) H(2) . . . H(k), where k = min(m,n). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**T +* +* where tau is a real scalar, and v is a real vector with +* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), +* and tau in TAU(i). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K + DOUBLE PRECISION AII +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQR2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = 1, K +* +* Generate elementary reflector H(i) to annihilate A(i+1:m,i) +* + CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, + $ TAU( I ) ) + IF( I.LT.N ) THEN +* +* Apply H(i) to A(i:m,i+1:n) from the left +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + A( I, I ) = AII + END IF + 10 CONTINUE + RETURN +* +* End of DGEQR2 +* + END + SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DGEQRF computes a QR factorization of a real M-by-N matrix A: +* A = Q * R. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the M-by-N matrix A. +* On exit, the elements on and above the diagonal of the array +* contain the min(M,N)-by-N upper trapezoidal matrix R (R is +* upper triangular if m >= n); the elements below the diagonal, +* with the array TAU, represent the orthogonal matrix Q as a +* product of min(m,n) elementary reflectors (see Further +* Details). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) +* The scalar factors of the elementary reflectors (see Further +* Details). +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension +* (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= max(1,N). +* For optimum performance LWORK >= N*NB, where NB is +* the optimal blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further Details +* =============== +* +* The matrix Q is represented as a product of elementary reflectors +* +* Q = H(1) H(2) . . . H(k), where k = min(m,n). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**T +* +* where tau is a real scalar, and v is a real vector with +* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), +* and tau in TAU(i). +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQRF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + K = MIN( M, N ) + IF( K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, + $ -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code initially +* + DO 10 I = 1, K - NX, NB + IB = MIN( K-I+1, NB ) +* +* Compute the QR factorization of the current block +* A(i:m,i:i+ib-1) +* + CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) + IF( I+IB.LE.N ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, + $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H**T to A(i:m,i+ib:n) from the left +* + CALL DLARFB( 'Left', 'Transpose', 'Forward', + $ 'Columnwise', M-I+1, N-I-IB+1, IB, + $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), + $ LDA, WORK( IB+1 ), LDWORK ) + END IF + 10 CONTINUE + ELSE + I = 1 + END IF +* +* Use unblocked code to factor the last or only block. +* + IF( I.LE.K ) + $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* + WORK( 1 ) = IWS + RETURN +* +* End of DGEQRF +* + END + SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DGETF2 computes an LU factorization of a general m-by-n matrix A +* using partial pivoting with row interchanges. +* +* The factorization has the form +* A = P * L * U +* where P is a permutation matrix, L is lower triangular with unit +* diagonal elements (lower trapezoidal if m > n), and U is upper +* triangular (upper trapezoidal if m < n). +* +* This is the right-looking Level 2 BLAS version of the algorithm. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the m by n matrix to be factored. +* On exit, the factors L and U from the factorization +* A = P*L*U; the unit diagonal elements of L are not stored. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* IPIV (output) INTEGER array, dimension (min(M,N)) +* The pivot indices; for 1 <= i <= min(M,N), row i of the +* matrix was interchanged with row IPIV(i). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -k, the k-th argument had an illegal value +* > 0: if INFO = k, U(k,k) is exactly zero. The factorization +* has been completed, but the factor U is exactly +* singular, and division by zero will occur if it is used +* to solve a system of equations. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION SFMIN + INTEGER I, J, JP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER IDAMAX + EXTERNAL DLAMCH, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL DGER, DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Compute machine safe minimum +* + SFMIN = DLAMCH('S') +* + DO 10 J = 1, MIN( M, N ) +* +* Find pivot and test for singularity. +* + JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) + IPIV( J ) = JP + IF( A( JP, J ).NE.ZERO ) THEN +* +* Apply the interchange to columns 1:N. +* + IF( JP.NE.J ) + $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) +* +* Compute elements J+1:M of J-th column. +* + IF( J.LT.M ) THEN + IF( ABS(A( J, J )) .GE. SFMIN ) THEN + CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) + ELSE + DO 20 I = 1, M-J + A( J+I, J ) = A( J+I, J ) / A( J, J ) + 20 CONTINUE + END IF + END IF +* + ELSE IF( INFO.EQ.0 ) THEN +* + INFO = J + END IF +* + IF( J.LT.MIN( M, N ) ) THEN +* +* Update trailing submatrix. +* + CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, + $ A( J+1, J+1 ), LDA ) + END IF + 10 CONTINUE + RETURN +* +* End of DGETF2 +* + END + SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DGETRF computes an LU factorization of a general M-by-N matrix A +* using partial pivoting with row interchanges. +* +* The factorization has the form +* A = P * L * U +* where P is a permutation matrix, L is lower triangular with unit +* diagonal elements (lower trapezoidal if m > n), and U is upper +* triangular (upper trapezoidal if m < n). +* +* This is the right-looking Level 3 BLAS version of the algorithm. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the M-by-N matrix to be factored. +* On exit, the factors L and U from the factorization +* A = P*L*U; the unit diagonal elements of L are not stored. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* IPIV (output) INTEGER array, dimension (min(M,N)) +* The pivot indices; for 1 <= i <= min(M,N), row i of the +* matrix was interchanged with row IPIV(i). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, U(i,i) is exactly zero. The factorization +* has been completed, but the factor U is exactly +* singular, and division by zero will occur if it is used +* to solve a system of equations. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IINFO, J, JB, NB +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN +* +* Use unblocked code. +* + CALL DGETF2( M, N, A, LDA, IPIV, INFO ) + ELSE +* +* Use blocked code. +* + DO 20 J = 1, MIN( M, N ), NB + JB = MIN( MIN( M, N )-J+1, NB ) +* +* Factor diagonal and subdiagonal blocks and test for exact +* singularity. +* + CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) +* +* Adjust INFO and the pivot indices. +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + J - 1 + DO 10 I = J, MIN( M, J+JB-1 ) + IPIV( I ) = J - 1 + IPIV( I ) + 10 CONTINUE +* +* Apply interchanges to columns 1:J-1. +* + CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) +* + IF( J+JB.LE.N ) THEN +* +* Apply interchanges to columns J+JB:N. +* + CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, + $ IPIV, 1 ) +* +* Compute block row of U. +* + CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, + $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), + $ LDA ) + IF( J+JB.LE.M ) THEN +* +* Update trailing submatrix. +* + CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, + $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, + $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), + $ LDA ) + END IF + END IF + 20 CONTINUE + END IF + RETURN +* +* End of DGETRF +* + END + SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* Purpose +* ======= +* +* DGETRS solves a system of linear equations +* A * X = B or A**T * X = B +* with a general N-by-N matrix A using the LU factorization computed +* by DGETRF. +* +* Arguments +* ========= +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T* X = B (Transpose) +* = 'C': A**T* X = B (Conjugate transpose = Transpose) +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrix B. NRHS >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The factors L and U from the factorization A = P*L*U +* as computed by DGETRF. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* IPIV (input) INTEGER array, dimension (N) +* The pivot indices from DGETRF; for 1<=i<=N, row i of the +* matrix was interchanged with row IPIV(i). +* +* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) +* On entry, the right hand side matrix B. +* On exit, the solution matrix X. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLASWP, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( NOTRAN ) THEN +* +* Solve A * X = B. +* +* Apply row interchanges to the right hand sides. +* + CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) +* +* Solve L*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve U*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, A, LDA, B, LDB ) + ELSE +* +* Solve A**T * X = B. +* +* Solve U**T *X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve L**T *X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, + $ A, LDA, B, LDB ) +* +* Apply row interchanges to the solution vectors. +* + CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) + END IF +* + RETURN +* +* End of DGETRS +* + END + DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y +* .. +* +* Purpose +* ======= +* +* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary +* overflow. +* +* Arguments +* ========= +* +* X (input) DOUBLE PRECISION +* Y (input) DOUBLE PRECISION +* X and Y specify the values x and y. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION W, XABS, YABS, Z +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + XABS = ABS( X ) + YABS = ABS( Y ) + W = MAX( XABS, YABS ) + Z = MIN( XABS, YABS ) + IF( Z.EQ.ZERO ) THEN + DLAPY2 = W + ELSE + DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) + END IF + RETURN +* +* End of DLAPY2 +* + END + SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, + $ WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, +* -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER LDA, M, N, OFFSET +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, MN, OFFPI, PVT + DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 +* .. +* .. Executable Statements .. +* + MN = MIN( M-OFFSET, N ) + TOL3Z = SQRT(DLAMCH('EPSILON')) +* +* Compute factorization. +* + DO 20 I = 1, MN +* + OFFPI = OFFSET + I +* +* Determine ith pivot column and swap if necessary. +* + PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 ) +* + IF( PVT.NE.I ) THEN + CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( I ) + JPVT( I ) = ITEMP + VN1( PVT ) = VN1( I ) + VN2( PVT ) = VN2( I ) + END IF +* +* Generate elementary reflector H(i). +* + IF( OFFPI.LT.M ) THEN + CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, + $ TAU( I ) ) + ELSE + CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) + END IF +* + IF( I.LT.N ) THEN +* +* Apply H(i)**T to A(offset+i:m,i+1:n) from the left. +* + AII = A( OFFPI, I ) + A( OFFPI, I ) = ONE + CALL DLARF( 'LEFT', M-OFFPI+1, N-I, A( OFFPI, I ), 1, + $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) + A( OFFPI, I ) = AII + END IF +* +* Update partial column norms. +* + DO 10 J = I + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following 4 lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN + IF( OFFPI.LT.M ) THEN + VN1( J ) = DNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) + VN2( J ) = VN1( J ) + ELSE + VN1( J ) = ZERO + VN2( J ) = ZERO + END IF + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + 10 CONTINUE +* + 20 CONTINUE +* + RETURN +* +* End of DLAQP2 +* + END + SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, + $ VN2, AUXV, F, LDF ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, +* -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER KB, LDA, LDF, M, N, NB, OFFSET +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), + $ VN1( * ), VN2( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK + DOUBLE PRECISION AKK, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, NINT, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 +* .. +* .. Executable Statements .. +* + LASTRK = MIN( M, N+OFFSET ) + LSTICC = 0 + K = 0 + TOL3Z = SQRT(DLAMCH('EPSILON')) +* +* Beginning of while loop. +* + 10 CONTINUE + IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN + K = K + 1 + RK = OFFSET + K +* +* Determine ith pivot column and swap if necessary +* + PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) + IF( PVT.NE.K ) THEN + CALL DSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 ) + CALL DSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( K ) + JPVT( K ) = ITEMP + VN1( PVT ) = VN1( K ) + VN2( PVT ) = VN2( K ) + END IF +* +* Apply previous Householder reflectors to column K: +* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**T. +* + IF( K.GT.1 ) THEN + CALL DGEMV( 'NO TRANSPOSE', M-RK+1, K-1, -ONE, A( RK, 1 ), + $ LDA, F( K, 1 ), LDF, ONE, A( RK, K ), 1 ) + END IF +* +* Generate elementary reflector H(k). +* + IF( RK.LT.M ) THEN + CALL DLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) + ELSE + CALL DLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) + END IF +* + AKK = A( RK, K ) + A( RK, K ) = ONE +* +* Compute Kth column of F: +* +* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**T*A(RK:M,K). +* + IF( K.LT.N ) THEN + CALL DGEMV( 'TRANSPOSE', M-RK+1, N-K, TAU( K ), + $ A( RK, K+1 ), LDA, A( RK, K ), 1, ZERO, + $ F( K+1, K ), 1 ) + END IF +* +* Padding F(1:K,K) with zeros. +* + DO 20 J = 1, K + F( J, K ) = ZERO + 20 CONTINUE +* +* Incremental updating of F: +* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**T +* *A(RK:M,K). +* + IF( K.GT.1 ) THEN + CALL DGEMV( 'TRANSPOSE', M-RK+1, K-1, -TAU( K ), A( RK, 1 ), + $ LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 ) +* + CALL DGEMV( 'NO TRANSPOSE', N, K-1, ONE, F( 1, 1 ), LDF, + $ AUXV( 1 ), 1, ONE, F( 1, K ), 1 ) + END IF +* +* Update the current row of A: +* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**T. +* + IF( K.LT.N ) THEN + CALL DGEMV( 'NO TRANSPOSE', N-K, K, -ONE, F( K+1, 1 ), LDF, + $ A( RK, 1 ), LDA, ONE, A( RK, K+1 ), LDA ) + END IF +* +* Update partial column norms. +* + IF( RK.LT.LASTRK ) THEN + DO 30 J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following 4 lines follow from the analysis +* in +* Lapack Working Note 176. +* + TEMP = ABS( A( RK, J ) ) / VN1( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN + VN2( J ) = DBLE( LSTICC ) + LSTICC = J + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE + END IF +* + A( RK, K ) = AKK +* +* End of while loop. +* + GO TO 10 + END IF + KB = K + RK = OFFSET + KB +* +* Apply the block reflector to the rest of the matrix: +* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - +* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**T. +* + IF( KB.LT.MIN( N, M-OFFSET ) ) THEN + CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M-RK, N-KB, KB, -ONE, + $ A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, + $ A( RK+1, KB+1 ), LDA ) + END IF +* +* Recomputation of difficult columns. +* + 40 CONTINUE + IF( LSTICC.GT.0 ) THEN + ITEMP = NINT( VN2( LSTICC ) ) + VN1( LSTICC ) = DNRM2( M-RK, A( RK+1, LSTICC ), 1 ) +* +* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* SNRM2 does not fail on vectors with norm below the value of +* SQRT(DLAMCH('S')) +* + VN2( LSTICC ) = VN1( LSTICC ) + LSTICC = ITEMP + GO TO 40 + END IF +* + RETURN +* +* End of DLAQPS +* + END + SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DLARF applies a real elementary reflector H to a real m by n matrix +* C, from either the left or the right. H is represented in the form +* +* H = I - tau * v * v**T +* +* where tau is a real scalar and v is a real vector. +* +* If tau = 0, then H is taken to be the unit matrix. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': form H * C +* = 'R': form C * H +* +* M (input) INTEGER +* The number of rows of the matrix C. +* +* N (input) INTEGER +* The number of columns of the matrix C. +* +* V (input) DOUBLE PRECISION array, dimension +* (1 + (M-1)*abs(INCV)) if SIDE = 'L' +* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +* The vector v in the representation of H. V is not used if +* TAU = 0. +* +* INCV (input) INTEGER +* The increment between elements of v. INCV <> 0. +* +* TAU (input) DOUBLE PRECISION +* The value tau in the representation of H. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m by n matrix C. +* On exit, C is overwritten by the matrix H * C if SIDE = 'L', +* or C * H if SIDE = 'R'. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension +* (N) if SIDE = 'L' +* or (M) if SIDE = 'R' +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILADLR, ILADLC + EXTERNAL LSAME, ILADLR, ILADLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 0 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V. + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILADLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILADLR(M, LASTV, C, LDC) + END IF + END IF +! Note that lastc.eq.0 renders the BLAS operations null; no special +! case is needed at this level. + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) +* + CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, + $ ZERO, WORK, 1 ) +* +* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * +* w(1:lastc,1)**T +* + CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) +* + CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, + $ V, INCV, ZERO, WORK, 1 ) +* +* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * +* v(1:lastv,1)**T +* + CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) + END IF + END IF + RETURN +* +* End of DLARF +* + END + SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, + $ T, LDT, C, LDC, WORK, LDWORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), + $ WORK( LDWORK, * ) +* .. +* +* Purpose +* ======= +* +* DLARFB applies a real block reflector H or its transpose H**T to a +* real m by n matrix C, from either the left or the right. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply H or H**T from the Left +* = 'R': apply H or H**T from the Right +* +* TRANS (input) CHARACTER*1 +* = 'N': apply H (No transpose) +* = 'T': apply H**T (Transpose) +* +* DIRECT (input) CHARACTER*1 +* Indicates how H is formed from a product of elementary +* reflectors +* = 'F': H = H(1) H(2) . . . H(k) (Forward) +* = 'B': H = H(k) . . . H(2) H(1) (Backward) +* +* STOREV (input) CHARACTER*1 +* Indicates how the vectors which define the elementary +* reflectors are stored: +* = 'C': Columnwise +* = 'R': Rowwise +* +* M (input) INTEGER +* The number of rows of the matrix C. +* +* N (input) INTEGER +* The number of columns of the matrix C. +* +* K (input) INTEGER +* The order of the matrix T (= the number of elementary +* reflectors whose product defines the block reflector). +* +* V (input) DOUBLE PRECISION array, dimension +* (LDV,K) if STOREV = 'C' +* (LDV,M) if STOREV = 'R' and SIDE = 'L' +* (LDV,N) if STOREV = 'R' and SIDE = 'R' +* The matrix V. See Further Details. +* +* LDV (input) INTEGER +* The leading dimension of the array V. +* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); +* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); +* if STOREV = 'R', LDV >= K. +* +* T (input) DOUBLE PRECISION array, dimension (LDT,K) +* The triangular k by k matrix T in the representation of the +* block reflector. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= K. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m by n matrix C. +* On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) +* +* LDWORK (input) INTEGER +* The leading dimension of the array WORK. +* If SIDE = 'L', LDWORK >= max(1,N); +* if SIDE = 'R', LDWORK >= max(1,M). +* +* Further Details +* =============== +* +* The shape of the matrix V and the storage of the vectors which define +* the H(i) is best illustrated by the following example with n = 5 and +* k = 3. The elements equal to 1 are not stored; the corresponding +* array elements are modified but restored on exit. The rest of the +* array is not used. +* +* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +* +* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +* ( v1 1 ) ( 1 v2 v2 v2 ) +* ( v1 v2 1 ) ( 1 v3 v3 ) +* ( v1 v2 v3 ) +* ( v1 v2 v3 ) +* +* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +* +* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +* ( v1 v2 v3 ) ( v2 v2 v2 1 ) +* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +* ( 1 v3 ) +* ( 1 ) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + CHARACTER TRANST + INTEGER I, J, LASTV, LASTC +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILADLR, ILADLC + EXTERNAL LSAME, ILADLR, ILADLC +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DTRMM +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* + IF( LSAME( TRANS, 'N' ) ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* + IF( LSAME( STOREV, 'C' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 ) (first K rows) +* ( V2 ) +* where V1 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in +* WORK) +* +* W := C1**T +* + DO 10 J = 1, K + CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 10 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2**T *V2 +* + CALL DGEMM( 'Transpose', 'No transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**T +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - V2 * W**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTV-K, LASTC, K, + $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**T +* + DO 30 J = 1, K + DO 20 I = 1, LASTC + C( J, I ) = C( J, I ) - WORK( I, J ) + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C1 +* + DO 40 J = 1, K + CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + 40 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2 * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**T +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - W * V2**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, LASTV-K, K, + $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 60 J = 1, K + DO 50 I = 1, LASTC + C( I, J ) = C( I, J ) - WORK( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + ELSE +* +* Let V = ( V1 ) +* ( V2 ) (last K rows) +* where V2 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in +* WORK) +* +* W := C2**T +* + DO 70 J = 1, K + CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, + $ WORK( 1, J ), 1 ) + 70 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1**T*V1 +* + CALL DGEMM( 'Transpose', 'No transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**T +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - V1 * W**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) + END IF +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W**T +* + DO 90 J = 1, K + DO 80 I = 1, LASTC + C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C2 +* + DO 100 J = 1, K + CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 100 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1 * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**T +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - W * V1**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, + $ ONE, C, LDC ) + END IF +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W +* + DO 120 J = 1, K + DO 110 I = 1, LASTC + C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) + 110 CONTINUE + 120 CONTINUE + END IF + END IF +* + ELSE IF( LSAME( STOREV, 'R' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 V2 ) (V1: first K columns) +* where V1 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) +* (stored in WORK) +* +* W := C1**T +* + DO 130 J = 1, K + CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 130 CONTINUE +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2**T*V2**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**T * W**T +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - V2**T * W**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTV-K, LASTC, K, + $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, + $ ONE, C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**T +* + DO 150 J = 1, K + DO 140 I = 1, LASTC + C( J, I ) = C( J, I ) - WORK( I, J ) + 140 CONTINUE + 150 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) +* +* W := C1 +* + DO 160 J = 1, K + CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + 160 CONTINUE +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2 * V2**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - W * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, LASTV-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, + $ ONE, C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 180 J = 1, K + DO 170 I = 1, LASTC + C( I, J ) = C( I, J ) - WORK( I, J ) + 170 CONTINUE + 180 CONTINUE +* + END IF +* + ELSE +* +* Let V = ( V1 V2 ) (V2: last K columns) +* where V2 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) +* (stored in WORK) +* +* W := C2**T +* + DO 190 J = 1, K + CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, + $ WORK( 1, J ), 1 ) + 190 CONTINUE +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1**T * V1**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**T * W**T +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - V1**T * W**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W**T +* + DO 210 J = 1, K + DO 200 I = 1, LASTC + C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) + 200 CONTINUE + 210 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) +* +* W := C2 +* + DO 220 J = 1, K + CALL DCOPY( LASTC, C( 1, LASTV-K+J ), 1, + $ WORK( 1, J ), 1 ) + 220 CONTINUE +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1 * V1**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - W * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, + $ ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 240 J = 1, K + DO 230 I = 1, LASTC + C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) + 230 CONTINUE + 240 CONTINUE +* + END IF +* + END IF + END IF +* + RETURN +* +* End of DLARFB +* + END + SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION ALPHA, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* Purpose +* ======= +* +* DLARFG generates a real elementary reflector H of order n, such +* that +* +* H * ( alpha ) = ( beta ), H**T * H = I. +* ( x ) ( 0 ) +* +* where alpha and beta are scalars, and x is an (n-1)-element real +* vector. H is represented in the form +* +* H = I - tau * ( 1 ) * ( 1 v**T ) , +* ( v ) +* +* where tau is a real scalar and v is a real (n-1)-element +* vector. +* +* If the elements of x are all zero, then tau = 0 and H is taken to be +* the unit matrix. +* +* Otherwise 1 <= tau <= 2. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the elementary reflector. +* +* ALPHA (input/output) DOUBLE PRECISION +* On entry, the value alpha. +* On exit, it is overwritten with the value beta. +* +* X (input/output) DOUBLE PRECISION array, dimension +* (1+(N-2)*abs(INCX)) +* On entry, the vector x. +* On exit, it is overwritten with the vector v. +* +* INCX (input) INTEGER +* The increment between elements of X. INCX > 0. +* +* TAU (output) DOUBLE PRECISION +* The value tau. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER J, KNT + DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 + EXTERNAL DLAMCH, DLAPY2, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN +* .. +* .. External Subroutines .. + EXTERNAL DSCAL +* .. +* .. Executable Statements .. +* + IF( N.LE.1 ) THEN + TAU = ZERO + RETURN + END IF +* + XNORM = DNRM2( N-1, X, INCX ) +* + IF( XNORM.EQ.ZERO ) THEN +* +* H = I +* + TAU = ZERO + ELSE +* +* general case +* + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) + KNT = 0 + IF( ABS( BETA ).LT.SAFMIN ) THEN +* +* XNORM, BETA may be inaccurate; scale X and recompute them +* + RSAFMN = ONE / SAFMIN + 10 CONTINUE + KNT = KNT + 1 + CALL DSCAL( N-1, RSAFMN, X, INCX ) + BETA = BETA*RSAFMN + ALPHA = ALPHA*RSAFMN + IF( ABS( BETA ).LT.SAFMIN ) + $ GO TO 10 +* +* New BETA is at most 1, at least SAFMIN +* + XNORM = DNRM2( N-1, X, INCX ) + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + END IF + TAU = ( BETA-ALPHA ) / BETA + CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) +* +* If ALPHA is subnormal, it may lose relative accuracy +* + DO 20 J = 1, KNT + BETA = BETA*SAFMIN + 20 CONTINUE + ALPHA = BETA + END IF +* + RETURN +* +* End of DLARFG +* + END + SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* Purpose +* ======= +* +* DLARFT forms the triangular factor T of a real block reflector H +* of order n, which is defined as a product of k elementary reflectors. +* +* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; +* +* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. +* +* If STOREV = 'C', the vector which defines the elementary reflector +* H(i) is stored in the i-th column of the array V, and +* +* H = I - V * T * V**T +* +* If STOREV = 'R', the vector which defines the elementary reflector +* H(i) is stored in the i-th row of the array V, and +* +* H = I - V**T * T * V +* +* Arguments +* ========= +* +* DIRECT (input) CHARACTER*1 +* Specifies the order in which the elementary reflectors are +* multiplied to form the block reflector: +* = 'F': H = H(1) H(2) . . . H(k) (Forward) +* = 'B': H = H(k) . . . H(2) H(1) (Backward) +* +* STOREV (input) CHARACTER*1 +* Specifies how the vectors which define the elementary +* reflectors are stored (see also Further Details): +* = 'C': columnwise +* = 'R': rowwise +* +* N (input) INTEGER +* The order of the block reflector H. N >= 0. +* +* K (input) INTEGER +* The order of the triangular factor T (= the number of +* elementary reflectors). K >= 1. +* +* V (input/output) DOUBLE PRECISION array, dimension +* (LDV,K) if STOREV = 'C' +* (LDV,N) if STOREV = 'R' +* The matrix V. See further details. +* +* LDV (input) INTEGER +* The leading dimension of the array V. +* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i). +* +* T (output) DOUBLE PRECISION array, dimension (LDT,K) +* The k by k triangular factor T of the block reflector. +* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is +* lower triangular. The rest of the array is not used. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= K. +* +* Further Details +* =============== +* +* The shape of the matrix V and the storage of the vectors which define +* the H(i) is best illustrated by the following example with n = 5 and +* k = 3. The elements equal to 1 are not stored; the corresponding +* array elements are modified but restored on exit. The rest of the +* array is not used. +* +* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +* +* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +* ( v1 1 ) ( 1 v2 v2 v2 ) +* ( v1 v2 1 ) ( 1 v3 v3 ) +* ( v1 v2 v3 ) +* ( v1 v2 v3 ) +* +* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +* +* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +* ( v1 v2 v3 ) ( v2 v2 v2 1 ) +* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +* ( 1 v3 ) +* ( 1 ) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, PREVLASTV, LASTV + DOUBLE PRECISION VII +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DTRMV +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( LSAME( DIRECT, 'F' ) ) THEN + PREVLASTV = N + DO 20 I = 1, K + PREVLASTV = MAX( I, PREVLASTV ) + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 10 J = 1, I + T( J, I ) = ZERO + 10 CONTINUE + ELSE +* +* general case +* + VII = V( I, I ) + V( I, I ) = ONE + IF( LSAME( STOREV, 'C' ) ) THEN +! Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) +* + CALL DGEMV( 'Transpose', J-I+1, I-1, -TAU( I ), + $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, + $ T( 1, I ), 1 ) + ELSE +! Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T +* + CALL DGEMV( 'No transpose', I-1, J-I+1, -TAU( I ), + $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, + $ T( 1, I ), 1 ) + END IF + V( I, I ) = VII +* +* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) +* + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, + $ LDT, T( 1, I ), 1 ) + T( I, I ) = TAU( I ) + IF( I.GT.1 ) THEN + PREVLASTV = MAX( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + 20 CONTINUE + ELSE + PREVLASTV = 1 + DO 40 I = K, 1, -1 + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 30 J = I, K + T( J, I ) = ZERO + 30 CONTINUE + ELSE +* +* general case +* + IF( I.LT.K ) THEN + IF( LSAME( STOREV, 'C' ) ) THEN + VII = V( N-K+I, I ) + V( N-K+I, I ) = ONE +! Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) := +* - tau(i) * V(j:n-k+i,i+1:k)**T * +* V(j:n-k+i,i) +* + CALL DGEMV( 'Transpose', N-K+I-J+1, K-I, -TAU( I ), + $ V( J, I+1 ), LDV, V( J, I ), 1, ZERO, + $ T( I+1, I ), 1 ) + V( N-K+I, I ) = VII + ELSE + VII = V( I, N-K+I ) + V( I, N-K+I ) = ONE +! Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) := +* - tau(i) * V(i+1:k,j:n-k+i) * +* V(i,j:n-k+i)**T +* + CALL DGEMV( 'No transpose', K-I, N-K+I-J+1, + $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, + $ ZERO, T( I+1, I ), 1 ) + V( I, N-K+I ) = VII + END IF +* +* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) +* + CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, + $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + IF( I.GT.1 ) THEN + PREVLASTV = MIN( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + T( I, I ) = TAU( I ) + END IF + 40 CONTINUE + END IF + RETURN +* +* End of DLARFT +* + END + SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, K1, K2, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DLASWP performs a series of row interchanges on the matrix A. +* One row interchange is initiated for each of rows K1 through K2 of A. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The number of columns of the matrix A. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the matrix of column dimension N to which the row +* interchanges will be applied. +* On exit, the permuted matrix. +* +* LDA (input) INTEGER +* The leading dimension of the array A. +* +* K1 (input) INTEGER +* The first element of IPIV for which a row interchange will +* be done. +* +* K2 (input) INTEGER +* The last element of IPIV for which a row interchange will +* be done. +* +* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) +* The vector of pivot indices. Only the elements in positions +* K1 through K2 of IPIV are accessed. +* IPIV(K) = L implies rows K and L are to be interchanged. +* +* INCX (input) INTEGER +* The increment between successive values of IPIV. If IPIV +* is negative, the pivots are applied in reverse order. +* +* Further Details +* =============== +* +* Modified by +* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 + DOUBLE PRECISION TEMP +* .. +* .. Executable Statements .. +* +* Interchange row I with row IPIV(I) for each of rows K1 through K2. +* + IF( INCX.GT.0 ) THEN + IX0 = K1 + I1 = K1 + I2 = K2 + INC = 1 + ELSE IF( INCX.LT.0 ) THEN + IX0 = 1 + ( 1-K2 )*INCX + I1 = K2 + I2 = K1 + INC = -1 + ELSE + RETURN + END IF +* + N32 = ( N / 32 )*32 + IF( N32.NE.0 ) THEN + DO 30 J = 1, N32, 32 + IX = IX0 + DO 20 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 10 K = J, J + 31 + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 10 CONTINUE + END IF + IX = IX + INCX + 20 CONTINUE + 30 CONTINUE + END IF + IF( N32.NE.N ) THEN + N32 = N32 + 1 + IX = IX0 + DO 50 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 40 K = N32, N + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 40 CONTINUE + END IF + IX = IX + INCX + 50 CONTINUE + END IF +* + RETURN +* +* End of DLASWP +* + END + SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORM2R overwrites the general real m by n matrix C with +* +* Q * C if SIDE = 'L' and TRANS = 'N', or +* +* Q**T* C if SIDE = 'L' and TRANS = 'T', or +* +* C * Q if SIDE = 'R' and TRANS = 'N', or +* +* C * Q**T if SIDE = 'R' and TRANS = 'T', +* +* where Q is a real orthogonal matrix defined as the product of k +* elementary reflectors +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n +* if SIDE = 'R'. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply Q or Q**T from the Left +* = 'R': apply Q or Q**T from the Right +* +* TRANS (input) CHARACTER*1 +* = 'N': apply Q (No transpose) +* = 'T': apply Q**T (Transpose) +* +* M (input) INTEGER +* The number of rows of the matrix C. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix C. N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines +* the matrix Q. +* If SIDE = 'L', M >= K >= 0; +* if SIDE = 'R', N >= K >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,K) +* The i-th column must contain the vector which defines the +* elementary reflector H(i), for i = 1,2,...,k, as returned by +* DGEQRF in the first k columns of its array argument A. +* A is modified by the routine but restored on exit. +* +* LDA (input) INTEGER +* The leading dimension of the array A. +* If SIDE = 'L', LDA >= max(1,M); +* if SIDE = 'R', LDA >= max(1,N). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DGEQRF. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m by n matrix C. +* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension +* (N) if SIDE = 'L', +* (M) if SIDE = 'R' +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + DOUBLE PRECISION AII +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORM2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) + $ THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), + $ LDC, WORK ) + A( I, I ) = AII + 10 CONTINUE + RETURN +* +* End of DORM2R +* + END + SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORMQR overwrites the general real M-by-N matrix C with +* +* SIDE = 'L' SIDE = 'R' +* TRANS = 'N': Q * C C * Q +* TRANS = 'T': Q**T * C C * Q**T +* +* where Q is a real orthogonal matrix defined as the product of k +* elementary reflectors +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N +* if SIDE = 'R'. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply Q or Q**T from the Left; +* = 'R': apply Q or Q**T from the Right. +* +* TRANS (input) CHARACTER*1 +* = 'N': No transpose, apply Q; +* = 'T': Transpose, apply Q**T. +* +* M (input) INTEGER +* The number of rows of the matrix C. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix C. N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines +* the matrix Q. +* If SIDE = 'L', M >= K >= 0; +* if SIDE = 'R', N >= K >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,K) +* The i-th column must contain the vector which defines the +* elementary reflector H(i), for i = 1,2,...,k, as returned by +* DGEQRF in the first k columns of its array argument A. +* A is modified by the routine but restored on exit. +* +* LDA (input) INTEGER +* The leading dimension of the array A. +* If SIDE = 'L', LDA >= max(1,M); +* if SIDE = 'R', LDA >= max(1,N). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DGEQRF. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the M-by-N matrix C. +* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension +* (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. +* If SIDE = 'L', LWORK >= max(1,N); +* if SIDE = 'R', LWORK >= max(1,M). +* For optimum performance LWORK >= N*NB if SIDE = 'L', and +* LWORK >= M*NB if SIDE = 'R', where NB is the optimal +* blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + DOUBLE PRECISION T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. NB may be at most NBMAX, where NBMAX +* is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), + $ LDA, TAU( I ), T, LDT ) + IF( LEFT ) THEN +* +* H or H**T is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H or H**T is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H or H**T +* + CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, + $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, + $ WORK, LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMQR +* + END + DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* -- LAPACK auxiliary routine (version 3.3.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* Based on LAPACK DLAMCH but with Fortran 95 query functions +* See: http://www.cs.utk.edu/~luszczek/lapack/lamch.html +* and +* http://www.netlib.org/lapack-dev/lapack-coding/program-style.html#id2537289 +* July 2010 +* +* .. Scalar Arguments .. + CHARACTER CMACH +* .. +* +* Purpose +* ======= +* +* DLAMCH determines double precision machine parameters. +* +* Arguments +* ========= +* +* CMACH (input) CHARACTER*1 +* Specifies the value to be returned by DLAMCH: +* = 'E' or 'e', DLAMCH := eps +* = 'S' or 's , DLAMCH := sfmin +* = 'B' or 'b', DLAMCH := base +* = 'P' or 'p', DLAMCH := eps*base +* = 'N' or 'n', DLAMCH := t +* = 'R' or 'r', DLAMCH := rnd +* = 'M' or 'm', DLAMCH := emin +* = 'U' or 'u', DLAMCH := rmin +* = 'L' or 'l', DLAMCH := emax +* = 'O' or 'o', DLAMCH := rmax +* +* where +* +* eps = relative machine precision +* sfmin = safe minimum, such that 1/sfmin does not overflow +* base = base of the machine +* prec = eps*base +* t = number of (base) digits in the mantissa +* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise +* emin = minimum exponent before (gradual) underflow +* rmin = underflow threshold - base**(emin-1) +* emax = largest exponent before overflow +* rmax = overflow threshold - (base**emax)*(1-eps) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, + $ MINEXPONENT, RADIX, TINY +* .. +* .. Executable Statements .. +* +* +* Assume rounding, not chopping. Always. +* + RND = ONE +* + IF( ONE.EQ.RND ) THEN + EPS = EPSILON(ZERO) * 0.5 + ELSE + EPS = EPSILON(ZERO) + END IF +* + IF( LSAME( CMACH, 'E' ) ) THEN + RMACH = EPS + ELSE IF( LSAME( CMACH, 'S' ) ) THEN + SFMIN = TINY(ZERO) + SMALL = ONE / HUGE(ZERO) + IF( SMALL.GE.SFMIN ) THEN +* +* Use SMALL plus a bit, to avoid the possibility of rounding +* causing overflow when computing 1/sfmin. +* + SFMIN = SMALL*( ONE+EPS ) + END IF + RMACH = SFMIN + ELSE IF( LSAME( CMACH, 'B' ) ) THEN + RMACH = RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'P' ) ) THEN + RMACH = EPS * RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'N' ) ) THEN + RMACH = DIGITS(ZERO) + ELSE IF( LSAME( CMACH, 'R' ) ) THEN + RMACH = RND + ELSE IF( LSAME( CMACH, 'M' ) ) THEN + RMACH = MINEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'U' ) ) THEN + RMACH = tiny(zero) + ELSE IF( LSAME( CMACH, 'L' ) ) THEN + RMACH = MAXEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'O' ) ) THEN + RMACH = HUGE(ZERO) + ELSE + RMACH = ZERO + END IF +* + DLAMCH = RMACH + RETURN +* +* End of DLAMCH +* + END +************************************************************************ +* + INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER ISPEC + REAL ONE, ZERO +* .. +* +* Purpose +* ======= +* +* IEEECK is called from the ILAENV to verify that Infinity and +* possibly NaN arithmetic is safe (i.e. will not trap). +* +* Arguments +* ========= +* +* ISPEC (input) INTEGER +* Specifies whether to test just for inifinity arithmetic +* or whether to test for infinity and NaN arithmetic. +* = 0: Verify infinity arithmetic only. +* = 1: Verify infinity and NaN arithmetic. +* +* ZERO (input) REAL +* Must contain the value 0.0 +* This is passed to prevent the compiler from optimizing +* away this code. +* +* ONE (input) REAL +* Must contain the value 1.0 +* This is passed to prevent the compiler from optimizing +* away this code. +* +* RETURN VALUE: INTEGER +* = 0: Arithmetic failed to produce the correct answers +* = 1: Arithmetic produced the correct answers +* +* ===================================================================== +* +* .. Local Scalars .. + REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, + $ NEGZRO, NEWZRO, POSINF +* .. +* .. Executable Statements .. + IEEECK = 1 +* + POSINF = ONE / ZERO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = -ONE / ZERO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGZRO = ONE / ( NEGINF+ONE ) + IF( NEGZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = ONE / NEGZRO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEWZRO = NEGZRO + ZERO + IF( NEWZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = ONE / NEWZRO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = NEGINF*POSINF + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = POSINF*POSINF + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* +* +* +* +* Return if we were only asked to check infinity arithmetic +* + IF( ISPEC.EQ.0 ) + $ RETURN +* + NAN1 = POSINF + NEGINF +* + NAN2 = POSINF / NEGINF +* + NAN3 = POSINF / POSINF +* + NAN4 = POSINF*ZERO +* + NAN5 = NEGINF*NEGZRO +* + NAN6 = NAN5*ZERO +* + IF( NAN1.EQ.NAN1 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN2.EQ.NAN2 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN3.EQ.NAN3 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN4.EQ.NAN4 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN5.EQ.NAN5 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN6.EQ.NAN6 ) THEN + IEEECK = 0 + RETURN + END IF +* + RETURN + END + INTEGER FUNCTION ILADLC( M, N, A, LDA ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.2.2) -- +* +* -- June 2010 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* ILADLC scans A for its last non-zero column. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. +* +* N (input) INTEGER +* The number of columns of the matrix A. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The m by n matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( N.EQ.0 ) THEN + ILADLC = N + ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILADLC = N + ELSE +* Now scan each column from the end, returning with the first +* non-zero. + DO ILADLC = N, 1, -1 + DO I = 1, M + IF( A(I, ILADLC).NE.ZERO ) RETURN + END DO + END DO + END IF + RETURN + END + INTEGER FUNCTION ILADLR( M, N, A, LDA ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* ILADLR scans A for its last non-zero row. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. +* +* N (input) INTEGER +* The number of columns of the matrix A. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The m by n matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( M.EQ.0 ) THEN + ILADLR = M + ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILADLR = M + ELSE +* Scan up each column tracking the last zero row seen. + ILADLR = 0 + DO J = 1, N + I=M + DO WHILE ((A(I,J).NE.ZERO).AND.(I.GE.1)) + I=I-1 + ENDDO + ILADLR = MAX( ILADLR, I ) + END DO + END IF + RETURN + END + INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* -- LAPACK auxiliary routine (version 3.2.1) -- +* +* -- April 2009 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* Purpose +* ======= +* +* ILAENV is called from the LAPACK routines to choose problem-dependent +* parameters for the local environment. See ISPEC for a description of +* the parameters. +* +* ILAENV returns an INTEGER +* if ILAENV >= 0: ILAENV returns the value of the parameter specified +* by ISPEC +* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal +* value. +* +* This version provides a set of parameters which should give good, +* but not optimal, performance on many of the currently available +* computers. Users are encouraged to modify this subroutine to set +* the tuning parameters for their particular machine using the option +* and problem size information in the arguments. +* +* This routine will not function correctly if it is converted to all +* lower case. Converting it to all upper case is allowed. +* +* Arguments +* ========= +* +* ISPEC (input) INTEGER +* Specifies the parameter to be returned as the value of +* ILAENV. +* = 1: the optimal blocksize; if this value is 1, an unblocked +* algorithm will give the best performance. +* = 2: the minimum block size for which the block routine +* should be used; if the usable block size is less than +* this value, an unblocked routine should be used. +* = 3: the crossover point (in a block routine, for N less +* than this value, an unblocked routine should be used) +* = 4: the number of shifts, used in the nonsymmetric +* eigenvalue routines (DEPRECATED) +* = 5: the minimum column dimension for blocking to be used; +* rectangular blocks must have dimension at least k by m, +* where k is given by ILAENV(2,...) and m by ILAENV(5,...) +* = 6: the crossover point for the SVD (when reducing an m by n +* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds +* this value, a QR factorization is used first to reduce +* the matrix to a triangular form.) +* = 7: the number of processors +* = 8: the crossover point for the multishift QR method +* for nonsymmetric eigenvalue problems (DEPRECATED) +* = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* =10: ieee NaN arithmetic can be trusted not to trap +* =11: infinity arithmetic can be trusted not to trap +* 12 <= ISPEC <= 16: +* xHSEQR or one of its subroutines, +* see IPARMQ for detailed explanation +* +* NAME (input) CHARACTER*(*) +* The name of the calling subroutine, in either upper case or +* lower case. +* +* OPTS (input) CHARACTER*(*) +* The character options to the subroutine NAME, concatenated +* into a single character string. For example, UPLO = 'U', +* TRANS = 'T', and DIAG = 'N' for a triangular routine would +* be specified as OPTS = 'UTN'. +* +* N1 (input) INTEGER +* N2 (input) INTEGER +* N3 (input) INTEGER +* N4 (input) INTEGER +* Problem dimensions for the subroutine NAME; these may not all +* be required. +* +* Further Details +* =============== +* +* The following conventions have been used when calling ILAENV from the +* LAPACK routines: +* 1) OPTS is a concatenation of all of the character options to +* subroutine NAME, in the same order that they appear in the +* argument list for NAME, even if they are not used in determining +* the value of the parameter specified by ISPEC. +* 2) The problem dimensions N1, N2, N3, N4 are specified in the order +* that they appear in the argument list for NAME. N1 is used +* first, N2 second, and so on, and unused problem dimensions are +* passed a value of -1. +* 3) The parameter value returned by ILAENV is checked for validity in +* the calling subroutine. For example, ILAENV is used to retrieve +* the optimal blocksize for STRTRI as follows: +* +* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) +* IF( NB.LE.1 ) NB = MAX( 1, N ) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IC, IZ, NB, NBMIN, NX + LOGICAL CNAME, SNAME + CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 +* .. +* .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, INT, MIN, REAL +* .. +* .. External Functions .. + INTEGER IEEECK, IPARMQ + EXTERNAL IEEECK, IPARMQ +* .. +* .. Executable Statements .. +* + GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, + $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC +* +* Invalid value for ISPEC +* + ILAENV = -1 + RETURN +* + 10 CONTINUE +* +* Convert NAME to upper case if the first character is lower case. +* + ILAENV = 1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 20 CONTINUE + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + 30 CONTINUE + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 40 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 40 CONTINUE + END IF + END IF +* + C1 = SUBNAM( 1: 1 ) + SNAME = C1.EQ.'S' .OR. C1.EQ.'D' + CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' + IF( .NOT.( CNAME .OR. SNAME ) ) + $ RETURN + C2 = SUBNAM( 2: 3 ) + C3 = SUBNAM( 4: 6 ) + C4 = C3( 2: 3 ) +* + GO TO ( 50, 60, 70 )ISPEC +* + 50 CONTINUE +* +* ISPEC = 1: block size +* +* In these examples, separate code is provided for setting NB for +* real and complex. We assume that NB will take the same value in +* single or double precision. +* + NB = 1 +* + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'PO' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRF' ) THEN + NB = 64 + ELSE IF( C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( C2.EQ.'GB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'PB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'TR' ) THEN + IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'LA' ) THEN + IF( C3.EQ.'UUM' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN + IF( C3.EQ.'EBZ' ) THEN + NB = 1 + END IF + END IF + ILAENV = NB + RETURN +* + 60 CONTINUE +* +* ISPEC = 2: minimum block size +* + NBMIN = 2 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NBMIN = 8 + ELSE + NBMIN = 8 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + END IF + ILAENV = NBMIN + RETURN +* + 70 CONTINUE +* +* ISPEC = 3: crossover point +* + NX = 0 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + END IF + ILAENV = NX + RETURN +* + 80 CONTINUE +* +* ISPEC = 4: number of shifts (used by xHSEQR) +* + ILAENV = 6 + RETURN +* + 90 CONTINUE +* +* ISPEC = 5: minimum column dimension (not used) +* + ILAENV = 2 + RETURN +* + 100 CONTINUE +* +* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) +* + ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) + RETURN +* + 110 CONTINUE +* +* ISPEC = 7: number of processors (not used) +* + ILAENV = 1 + RETURN +* + 120 CONTINUE +* +* ISPEC = 8: crossover point for multishift (used by xHSEQR) +* + ILAENV = 50 + RETURN +* + 130 CONTINUE +* +* ISPEC = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* + ILAENV = 25 + RETURN +* + 140 CONTINUE +* +* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 1, 0.0, 1.0 ) + END IF + RETURN +* + 150 CONTINUE +* +* ISPEC = 11: infinity arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 0, 0.0, 1.0 ) + END IF + RETURN +* + 160 CONTINUE +* +* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. +* + ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + RETURN +* +* End of ILAENV +* + END + INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, ISPEC, LWORK, N + CHARACTER NAME*( * ), OPTS*( * ) +* +* Purpose +* ======= +* +* This program sets problem and machine dependent parameters +* useful for xHSEQR and its subroutines. It is called whenever +* ILAENV is called with 12 <= ISPEC <= 16 +* +* Arguments +* ========= +* +* ISPEC (input) integer scalar +* ISPEC specifies which tunable parameter IPARMQ should +* return. +* +* ISPEC=12: (INMIN) Matrices of order nmin or less +* are sent directly to xLAHQR, the implicit +* double shift QR algorithm. NMIN must be +* at least 11. +* +* ISPEC=13: (INWIN) Size of the deflation window. +* This is best set greater than or equal to +* the number of simultaneous shifts NS. +* Larger matrices benefit from larger deflation +* windows. +* +* ISPEC=14: (INIBL) Determines when to stop nibbling and +* invest in an (expensive) multi-shift QR sweep. +* If the aggressive early deflation subroutine +* finds LD converged eigenvalues from an order +* NW deflation window and LD.GT.(NW*NIBBLE)/100, +* then the next QR sweep is skipped and early +* deflation is applied immediately to the +* remaining active diagonal block. Setting +* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a +* multi-shift QR sweep whenever early deflation +* finds a converged eigenvalue. Setting +* IPARMQ(ISPEC=14) greater than or equal to 100 +* prevents TTQRE from skipping a multi-shift +* QR sweep. +* +* ISPEC=15: (NSHFTS) The number of simultaneous shifts in +* a multi-shift QR iteration. +* +* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the +* following meanings. +* 0: During the multi-shift QR sweep, +* xLAQR5 does not accumulate reflections and +* does not use matrix-matrix multiply to +* update the far-from-diagonal matrix +* entries. +* 1: During the multi-shift QR sweep, +* xLAQR5 and/or xLAQRaccumulates reflections +* and uses +* matrix-matrix multiply to update the +* far-from-diagonal matrix entries. +* 2: During the multi-shift QR sweep. +* xLAQR5 accumulates reflections and takes +* advantage of 2-by-2 block structure during +* matrix-matrix multiplies. +* (If xTRMM is slower than xGEMM, then +* IPARMQ(ISPEC=16)=1 may be more efficient than +* IPARMQ(ISPEC=16)=2 despite the greater level of +* arithmetic work implied by the latter choice.) +* +* NAME (input) character string +* Name of the calling subroutine +* +* OPTS (input) character string +* This is a concatenation of the string arguments to +* TTQRE. +* +* N (input) integer scalar +* N is the order of the Hessenberg matrix H. +* +* ILO (input) INTEGER +* IHI (input) INTEGER +* It is assumed that H is already upper triangular +* in rows and columns 1:ILO-1 and IHI+1:N. +* +* LWORK (input) integer scalar +* The amount of workspace available. +* +* Further Details +* =============== +* +* Little is known about how best to choose these parameters. +* It is possible to use different values of the parameters +* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. +* +* It is probably best to choose different parameters for +* different matrices and different parameters at different +* times during the iteration, but this has not been +* implemented --- yet. +* +* +* The best choices of most of the parameters depend +* in an ill-understood way on the relative execution +* rate of xLAQR3 and xLAQR5 and on the nature of each +* particular eigenvalue problem. Experiment may be the +* only practical way to determine which choices are most +* effective. +* +* Following is a list of default values supplied by IPARMQ. +* These defaults may be adjusted in order to attain better +* performance in any particular computational environment. +* +* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. +* Default: 75. (Must be at least 11.) +* +* IPARMQ(ISPEC=13) Recommended deflation window size. +* This depends on ILO, IHI and NS, the +* number of simultaneous shifts returned +* by IPARMQ(ISPEC=15). The default for +* (IHI-ILO+1).LE.500 is NS. The default +* for (IHI-ILO+1).GT.500 is 3*NS/2. +* +* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. +* +* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. +* a multi-shift QR iteration. +* +* If IHI-ILO+1 is ... +* +* greater than ...but less ... the +* or equal to ... than default is +* +* 0 30 NS = 2+ +* 30 60 NS = 4+ +* 60 150 NS = 10 +* 150 590 NS = ** +* 590 3000 NS = 64 +* 3000 6000 NS = 128 +* 6000 infinity NS = 256 +* +* (+) By default matrices of this order are +* passed to the implicit double shift routine +* xLAHQR. See IPARMQ(ISPEC=12) above. These +* values of NS are used only in case of a rare +* xLAHQR failure. +* +* (**) The asterisks (**) indicate an ad-hoc +* function increasing from 10 to 64. +* +* IPARMQ(ISPEC=16) Select structured matrix multiply. +* (See ISPEC=16 above for details.) +* Default: 3. +* +* ================================================================ +* .. Parameters .. + INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 + PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, + $ ISHFTS = 15, IACC22 = 16 ) + INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP + PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, + $ NIBBLE = 14, KNWSWP = 500 ) + REAL TWO + PARAMETER ( TWO = 2.0 ) +* .. +* .. Local Scalars .. + INTEGER NH, NS +* .. +* .. Intrinsic Functions .. + INTRINSIC LOG, MAX, MOD, NINT, REAL +* .. +* .. Executable Statements .. + IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. + $ ( ISPEC.EQ.IACC22 ) ) THEN +* +* ==== Set the number simultaneous shifts ==== +* + NH = IHI - ILO + 1 + NS = 2 + IF( NH.GE.30 ) + $ NS = 4 + IF( NH.GE.60 ) + $ NS = 10 + IF( NH.GE.150 ) + $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) + IF( NH.GE.590 ) + $ NS = 64 + IF( NH.GE.3000 ) + $ NS = 128 + IF( NH.GE.6000 ) + $ NS = 256 + NS = MAX( 2, NS-MOD( NS, 2 ) ) + END IF +* + IF( ISPEC.EQ.INMIN ) THEN +* +* +* ===== Matrices of order smaller than NMIN get sent +* . to xLAHQR, the classic double shift algorithm. +* . This must be at least 11. ==== +* + IPARMQ = NMIN +* + ELSE IF( ISPEC.EQ.INIBL ) THEN +* +* ==== INIBL: skip a multi-shift qr iteration and +* . whenever aggressive early deflation finds +* . at least (NIBBLE*(window size)/100) deflations. ==== +* + IPARMQ = NIBBLE +* + ELSE IF( ISPEC.EQ.ISHFTS ) THEN +* +* ==== NSHFTS: The number of simultaneous shifts ===== +* + IPARMQ = NS +* + ELSE IF( ISPEC.EQ.INWIN ) THEN +* +* ==== NW: deflation window size. ==== +* + IF( NH.LE.KNWSWP ) THEN + IPARMQ = NS + ELSE + IPARMQ = 3*NS / 2 + END IF +* + ELSE IF( ISPEC.EQ.IACC22 ) THEN +* +* ==== IACC22: Whether to accumulate reflections +* . before updating the far-from-diagonal elements +* . and whether to use 2-by-2 block structure while +* . doing it. A small amount of work could be saved +* . by making this choice dependent also upon the +* . NH=IHI-ILO+1. +* + IPARMQ = 0 + IF( NS.GE.KACMIN ) + $ IPARMQ = 1 + IF( NS.GE.K22MIN ) + $ IPARMQ = 2 +* + ELSE +* ===== invalid value of ispec ===== + IPARMQ = -1 +* + END IF +* +* ==== End of IPARMQ ==== +* + END + diff --git a/c_binding/slatec.f b/c_binding/slatec.f new file mode 100644 index 0000000..c652a26 --- /dev/null +++ b/c_binding/slatec.f @@ -0,0 +1,5023 @@ +*DECK DLSEI + SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, + + RNORML, MODE, WS, IP) +C***BEGIN PROLOGUE DLSEI +C***PURPOSE Solve a linearly constrained least squares problem with +C equality and inequality constraints, and optionally compute +C a covariance matrix. +C***LIBRARY SLATEC +C***CATEGORY K1A2A, D9 +C***TYPE DOUBLE PRECISION (LSEI-S, DLSEI-D) +C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, +C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, +C QUADRATIC PROGRAMMING +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C Abstract +C +C This subprogram solves a linearly constrained least squares +C problem with both equality and inequality constraints, and, if the +C user requests, obtains a covariance matrix of the solution +C parameters. +C +C Suppose there are given matrices E, A and G of respective +C dimensions ME by N, MA by N and MG by N, and vectors F, B and H of +C respective lengths ME, MA and MG. This subroutine solves the +C linearly constrained least squares problem +C +C EX = F, (E ME by N) (equations to be exactly +C satisfied) +C AX = B, (A MA by N) (equations to be +C approximately satisfied, +C least squares sense) +C GX .GE. H,(G MG by N) (inequality constraints) +C +C The inequalities GX .GE. H mean that every component of the +C product GX must be .GE. the corresponding component of H. +C +C In case the equality constraints cannot be satisfied, a +C generalized inverse solution residual vector length is obtained +C for F-EX. This is the minimal length possible for F-EX. +C +C Any values ME .GE. 0, MA .GE. 0, or MG .GE. 0 are permitted. The +C rank of the matrix E is estimated during the computation. We call +C this value KRANKE. It is an output parameter in IP(1) defined +C below. Using a generalized inverse solution of EX=F, a reduced +C least squares problem with inequality constraints is obtained. +C The tolerances used in these tests for determining the rank +C of E and the rank of the reduced least squares problem are +C given in Sandia Tech. Rept. SAND-78-1290. They can be +C modified by the user if new values are provided in +C the option list of the array PRGOPT(*). +C +C The user must dimension all arrays appearing in the call list.. +C W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2) +C where K=MAX(MA+MG,N). This allows for a solution of a range of +C problems in the given working space. The dimension of WS(*) +C given is a necessary overestimate. Once a particular problem +C has been run, the output parameter IP(3) gives the actual +C dimension required for that problem. +C +C The parameters for DLSEI( ) are +C +C Input.. All TYPE REAL variables are DOUBLE PRECISION +C +C W(*,*),MDW, The array W(*,*) is doubly subscripted with +C ME,MA,MG,N first dimensioning parameter equal to MDW. +C For this discussion let us call M = ME+MA+MG. Then +C MDW must satisfy MDW .GE. M. The condition +C MDW .LT. M is an error. +C +C The array W(*,*) contains the matrices and vectors +C +C (E F) +C (A B) +C (G H) +C +C in rows and columns 1,...,M and 1,...,N+1 +C respectively. +C +C The integers ME, MA, and MG are the +C respective matrix row dimensions +C of E, A and G. Each matrix has N columns. +C +C PRGOPT(*) This real-valued array is the option vector. +C If the user is satisfied with the nominal +C subprogram features set +C +C PRGOPT(1)=1 (or PRGOPT(1)=1.0) +C +C Otherwise PRGOPT(*) is a linked list consisting of +C groups of data of the following form +C +C LINK +C KEY +C DATA SET +C +C The parameters LINK and KEY are each one word. +C The DATA SET can be comprised of several words. +C The number of items depends on the value of KEY. +C The value of LINK points to the first +C entry of the next group of data within +C PRGOPT(*). The exception is when there are +C no more options to change. In that +C case, LINK=1 and the values KEY and DATA SET +C are not referenced. The general layout of +C PRGOPT(*) is as follows. +C +C ...PRGOPT(1) = LINK1 (link to first entry of next group) +C . PRGOPT(2) = KEY1 (key to the option change) +C . PRGOPT(3) = data value (data value for this change) +C . . +C . . +C . . +C ...PRGOPT(LINK1) = LINK2 (link to the first entry of +C . next group) +C . PRGOPT(LINK1+1) = KEY2 (key to the option change) +C . PRGOPT(LINK1+2) = data value +C ... . +C . . +C . . +C ...PRGOPT(LINK) = 1 (no more options to change) +C +C Values of LINK that are nonpositive are errors. +C A value of LINK .GT. NLINK=100000 is also an error. +C This helps prevent using invalid but positive +C values of LINK that will probably extend +C beyond the program limits of PRGOPT(*). +C Unrecognized values of KEY are ignored. The +C order of the options is arbitrary and any number +C of options can be changed with the following +C restriction. To prevent cycling in the +C processing of the option array, a count of the +C number of options changed is maintained. +C Whenever this count exceeds NOPT=1000, an error +C message is printed and the subprogram returns. +C +C Options.. +C +C KEY=1 +C Compute in W(*,*) the N by N +C covariance matrix of the solution variables +C as an output parameter. Nominally the +C covariance matrix will not be computed. +C (This requires no user input.) +C The data set for this option is a single value. +C It must be nonzero when the covariance matrix +C is desired. If it is zero, the covariance +C matrix is not computed. When the covariance matrix +C is computed, the first dimensioning parameter +C of the array W(*,*) must satisfy MDW .GE. MAX(M,N). +C +C KEY=10 +C Suppress scaling of the inverse of the +C normal matrix by the scale factor RNORM**2/ +C MAX(1, no. of degrees of freedom). This option +C only applies when the option for computing the +C covariance matrix (KEY=1) is used. With KEY=1 and +C KEY=10 used as options the unscaled inverse of the +C normal matrix is returned in W(*,*). +C The data set for this option is a single value. +C When it is nonzero no scaling is done. When it is +C zero scaling is done. The nominal case is to do +C scaling so if option (KEY=1) is used alone, the +C matrix will be scaled on output. +C +C KEY=2 +C Scale the nonzero columns of the +C entire data matrix. +C (E) +C (A) +C (G) +C +C to have length one. The data set for this +C option is a single value. It must be +C nonzero if unit length column scaling +C is desired. +C +C KEY=3 +C Scale columns of the entire data matrix +C (E) +C (A) +C (G) +C +C with a user-provided diagonal matrix. +C The data set for this option consists +C of the N diagonal scaling factors, one for +C each matrix column. +C +C KEY=4 +C Change the rank determination tolerance for +C the equality constraint equations from +C the nominal value of SQRT(DRELPR). This quantity can +C be no smaller than DRELPR, the arithmetic- +C storage precision. The quantity DRELPR is the +C largest positive number such that T=1.+DRELPR +C satisfies T .EQ. 1. The quantity used +C here is internally restricted to be at +C least DRELPR. The data set for this option +C is the new tolerance. +C +C KEY=5 +C Change the rank determination tolerance for +C the reduced least squares equations from +C the nominal value of SQRT(DRELPR). This quantity can +C be no smaller than DRELPR, the arithmetic- +C storage precision. The quantity used +C here is internally restricted to be at +C least DRELPR. The data set for this option +C is the new tolerance. +C +C For example, suppose we want to change +C the tolerance for the reduced least squares +C problem, compute the covariance matrix of +C the solution parameters, and provide +C column scaling for the data matrix. For +C these options the dimension of PRGOPT(*) +C must be at least N+9. The Fortran statements +C defining these options would be as follows: +C +C PRGOPT(1)=4 (link to entry 4 in PRGOPT(*)) +C PRGOPT(2)=1 (covariance matrix key) +C PRGOPT(3)=1 (covariance matrix wanted) +C +C PRGOPT(4)=7 (link to entry 7 in PRGOPT(*)) +C PRGOPT(5)=5 (least squares equas. tolerance key) +C PRGOPT(6)=... (new value of the tolerance) +C +C PRGOPT(7)=N+9 (link to entry N+9 in PRGOPT(*)) +C PRGOPT(8)=3 (user-provided column scaling key) +C +C CALL DCOPY (N, D, 1, PRGOPT(9), 1) (Copy the N +C scaling factors from the user array D(*) +C to PRGOPT(9)-PRGOPT(N+8)) +C +C PRGOPT(N+9)=1 (no more options to change) +C +C The contents of PRGOPT(*) are not modified +C by the subprogram. +C The options for WNNLS( ) can also be included +C in this array. The values of KEY recognized +C by WNNLS( ) are 6, 7 and 8. Their functions +C are documented in the usage instructions for +C subroutine WNNLS( ). Normally these options +C do not need to be modified when using DLSEI( ). +C +C IP(1), The amounts of working storage actually +C IP(2) allocated for the working arrays WS(*) and +C IP(*), respectively. These quantities are +C compared with the actual amounts of storage +C needed by DLSEI( ). Insufficient storage +C allocated for either WS(*) or IP(*) is an +C error. This feature was included in DLSEI( ) +C because miscalculating the storage formulas +C for WS(*) and IP(*) might very well lead to +C subtle and hard-to-find execution errors. +C +C The length of WS(*) must be at least +C +C LW = 2*(ME+N)+K+(MG+2)*(N+7) +C +C where K = max(MA+MG,N) +C This test will not be made if IP(1).LE.0. +C +C The length of IP(*) must be at least +C +C LIP = MG+2*N+2 +C This test will not be made if IP(2).LE.0. +C +C Output.. All TYPE REAL variables are DOUBLE PRECISION +C +C X(*),RNORME, The array X(*) contains the solution parameters +C RNORML if the integer output flag MODE = 0 or 1. +C The definition of MODE is given directly below. +C When MODE = 0 or 1, RNORME and RNORML +C respectively contain the residual vector +C Euclidean lengths of F - EX and B - AX. When +C MODE=1 the equality constraint equations EX=F +C are contradictory, so RNORME .NE. 0. The residual +C vector F-EX has minimal Euclidean length. For +C MODE .GE. 2, none of these parameters is defined. +C +C MODE Integer flag that indicates the subprogram +C status after completion. If MODE .GE. 2, no +C solution has been computed. +C +C MODE = +C +C 0 Both equality and inequality constraints +C are compatible and have been satisfied. +C +C 1 Equality constraints are contradictory. +C A generalized inverse solution of EX=F was used +C to minimize the residual vector length F-EX. +C In this sense, the solution is still meaningful. +C +C 2 Inequality constraints are contradictory. +C +C 3 Both equality and inequality constraints +C are contradictory. +C +C The following interpretation of +C MODE=1,2 or 3 must be made. The +C sets consisting of all solutions +C of the equality constraints EX=F +C and all vectors satisfying GX .GE. H +C have no points in common. (In +C particular this does not say that +C each individual set has no points +C at all, although this could be the +C case.) +C +C 4 Usage error occurred. The value +C of MDW is .LT. ME+MA+MG, MDW is +C .LT. N and a covariance matrix is +C requested, or the option vector +C PRGOPT(*) is not properly defined, +C or the lengths of the working arrays +C WS(*) and IP(*), when specified in +C IP(1) and IP(2) respectively, are not +C long enough. +C +C W(*,*) The array W(*,*) contains the N by N symmetric +C covariance matrix of the solution parameters, +C provided this was requested on input with +C the option vector PRGOPT(*) and the output +C flag is returned with MODE = 0 or 1. +C +C IP(*) The integer working array has three entries +C that provide rank and working array length +C information after completion. +C +C IP(1) = rank of equality constraint +C matrix. Define this quantity +C as KRANKE. +C +C IP(2) = rank of reduced least squares +C problem. +C +C IP(3) = the amount of storage in the +C working array WS(*) that was +C actually used by the subprogram. +C The formula given above for the length +C of WS(*) is a necessary overestimate. +C If exactly the same problem matrices +C are used in subsequent executions, +C the declared dimension of WS(*) can +C be reduced to this output value. +C User Designated +C Working Arrays.. +C +C WS(*),IP(*) These are respectively type real +C and type integer working arrays. +C Their required minimal lengths are +C given above. +C +C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for +C linear least squares problems with equality and +C nonnegativity constraints, Report SAND77-0552, Sandia +C Laboratories, June 1978. +C K. H. Haskell and R. J. Hanson, Selected algorithms for +C the linearly constrained least squares problem - a +C users guide, Report SAND78-1290, Sandia Laboratories, +C August 1979. +C K. H. Haskell and R. J. Hanson, An algorithm for +C linear least squares problems with equality and +C nonnegativity constraints, Mathematical Programming +C 21 (1981), pp. 98-118. +C R. J. Hanson and K. H. Haskell, Two algorithms for the +C linearly constrained least squares problem, ACM +C Transactions on Mathematical Software, September 1982. +C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, +C DNRM2, DSCAL, DSWAP, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and extensively revised (WRB & RWC) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900510 Convert XERRWV calls to XERMSG calls. (RWC) +C 900604 DP version created from SP version. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C 180613 Removed prints and replaced DP --> DOUBLE PRECISION. (THC) +C***END PROLOGUE DLSEI + + INTEGER IP(3), MA, MDW, ME, MG, MODE, N + DOUBLE PRECISION PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*) +C + EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, DNRM2, + * DSCAL, DSWAP + DOUBLE PRECISION D1MACH, DASUM, DDOT, DNRM2 +C + DOUBLE PRECISION DRELPR, ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, + * SN, SNMAX, T, TAU, UJ, UP, VJ, XNORM, XNRME + INTEGER I, IMAX, J, JP1, K, KEY, KRANKE, LAST, LCHK, LINK, M, + * MAPKE1, MDEQC, MEND, MEP1, N1, N2, NEXT, NLINK, NOPT, NP1, + * NTIMES + LOGICAL COV, FIRST +C CHARACTER*8 XERN1, XERN2, XERN3, XERN4 + SAVE FIRST, DRELPR +C + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DLSEI +C +C Set the nominal tolerance used in the code for the equality +C constraint equations. +C + IF (FIRST) DRELPR = D1MACH(4) + FIRST = .FALSE. + TAU = SQRT(DRELPR) +C +C Check that enough storage was allocated in WS(*) and IP(*). +C + MODE = 4 + IF (MIN(N,ME,MA,MG) .LT. 0) THEN +C WRITE (XERN1, '(I8)') N +C WRITE (XERN2, '(I8)') ME +C WRITE (XERN3, '(I8)') MA +C WRITE (XERN4, '(I8)') MG +C CALL XERMSG ('SLATEC', 'LSEI', 'ALL OF THE VARIABLES N, ME,' // +C * ' MA, MG MUST BE .GE. 0$$ENTERED ROUTINE WITH' // +C * '$$N = ' // XERN1 // +C * '$$ME = ' // XERN2 // +C * '$$MA = ' // XERN3 // +C * '$$MG = ' // XERN4, 2, 1) + RETURN + ENDIF +C + IF (IP(1).GT.0) THEN + LCHK = 2*(ME+N) + MAX(MA+MG,N) + (MG+2)*(N+7) + IF (IP(1).LT.LCHK) THEN +C WRITE (XERN1, '(I8)') LCHK +C CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // +C * 'ALLOCATED FOR WS(*), NEED LW = ' // XERN1, 2, 1) + RETURN + ENDIF + ENDIF +C + IF (IP(2).GT.0) THEN + LCHK = MG + 2*N + 2 + IF (IP(2).LT.LCHK) THEN +C WRITE (XERN1, '(I8)') LCHK +C CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // +C * 'ALLOCATED FOR IP(*), NEED LIP = ' // XERN1, 2, 1) + RETURN + ENDIF + ENDIF +C +C Compute number of possible right multiplying Householder +C transformations. +C + M = ME + MA + MG + IF (N.LE.0 .OR. M.LE.0) THEN + MODE = 0 + RNORME = 0 + RNORML = 0 + RETURN + ENDIF +C + IF (MDW.LT.M) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', 'MDW.LT.ME+MA+MG IS AN ERROR', +C + 2, 1) + RETURN + ENDIF +C + NP1 = N + 1 + KRANKE = MIN(ME,N) + N1 = 2*KRANKE + 1 + N2 = N1 + N +C +C Set nominal values. +C +C The nominal column scaling used in the code is +C the identity scaling. +C + CALL DCOPY (N, 1.D0, 0, WS(N1), 1) +C +C No covariance matrix is nominally computed. +C + COV = .FALSE. +C +C Process option vector. +C Define bound for number of options to change. +C + NOPT = 1000 + NTIMES = 0 +C +C Define bound for positive values of LINK. +C + NLINK = 100000 + LAST = 1 + LINK = PRGOPT(1) + IF (LINK.EQ.0 .OR. LINK.GT.NLINK) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', +C + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) + RETURN + ENDIF +C + 100 IF (LINK.GT.1) THEN + NTIMES = NTIMES + 1 + IF (NTIMES.GT.NOPT) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', +C + 'THE LINKS IN THE OPTION VECTOR ARE CYCLING.', 2, 1) + RETURN + ENDIF +C + KEY = PRGOPT(LAST+1) + IF (KEY.EQ.1) THEN + COV = PRGOPT(LAST+2) .NE. 0.D0 + ELSEIF (KEY.EQ.2 .AND. PRGOPT(LAST+2).NE.0.D0) THEN + DO 110 J = 1,N + T = DNRM2(M,W(1,J),1) + IF (T.NE.0.D0) T = 1.D0/T + WS(J+N1-1) = T + 110 CONTINUE + ELSEIF (KEY.EQ.3) THEN + CALL DCOPY (N, PRGOPT(LAST+2), 1, WS(N1), 1) + ELSEIF (KEY.EQ.4) THEN + TAU = MAX(DRELPR,PRGOPT(LAST+2)) + ENDIF +C + NEXT = PRGOPT(LINK) + IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', +C + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) + RETURN + ENDIF +C + LAST = LINK + LINK = NEXT + GO TO 100 + ENDIF +C + DO 120 J = 1,N + CALL DSCAL (M, WS(N1+J-1), W(1,J), 1) + 120 CONTINUE +C + IF (COV .AND. MDW.LT.N) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', +C + 'MDW .LT. N WHEN COV MATRIX NEEDED, IS AN ERROR', 2, 1) + RETURN + ENDIF +C +C Problem definition and option vector OK. +C + MODE = 0 +C +C Compute norm of equality constraint matrix and right side. +C + ENORM = 0.D0 + DO 130 J = 1,N + ENORM = MAX(ENORM,DASUM(ME,W(1,J),1)) + 130 CONTINUE +C + FNORM = DASUM(ME,W(1,NP1),1) + SNMAX = 0.D0 + RNMAX = 0.D0 + DO 150 I = 1,KRANKE +C +C Compute maximum ratio of vector lengths. Partition is at +C column I. +C + DO 140 K = I,ME + SN = DDOT(N-I+1,W(K,I),MDW,W(K,I),MDW) + RN = DDOT(I-1,W(K,1),MDW,W(K,1),MDW) + IF (RN.EQ.0.D0 .AND. SN.GT.SNMAX) THEN + SNMAX = SN + IMAX = K + ELSEIF (K.EQ.I .OR. SN*RNMAX.GT.RN*SNMAX) THEN + SNMAX = SN + RNMAX = RN + IMAX = K + ENDIF + 140 CONTINUE +C +C Interchange rows if necessary. +C + IF (I.NE.IMAX) CALL DSWAP (NP1, W(I,1), MDW, W(IMAX,1), MDW) + IF (SNMAX.GT.RNMAX*TAU**2) THEN +C +C Eliminate elements I+1,...,N in row I. +C + CALL DH12 (1, I, I+1, N, W(I,1), MDW, WS(I), W(I+1,1), MDW, + + 1, M-I) + ELSE + KRANKE = I - 1 + GO TO 160 + ENDIF + 150 CONTINUE +C +C Save diagonal terms of lower trapezoidal matrix. +C + 160 CALL DCOPY (KRANKE, W, MDW+1, WS(KRANKE+1), 1) +C +C Use Householder transformation from left to achieve +C KRANKE by KRANKE upper triangular form. +C + IF (KRANKE.LT.ME) THEN + DO 170 K = KRANKE,1,-1 +C +C Apply transformation to matrix cols. 1,...,K-1. +C + CALL DH12 (1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, + * K-1) +C +C Apply to rt side vector. +C + CALL DH12 (2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, + + 1, 1) + 170 CONTINUE + ENDIF +C +C Solve for variables 1,...,KRANKE in new coordinates. +C + CALL DCOPY (KRANKE, W(1, NP1), 1, X, 1) + DO 180 I = 1,KRANKE + X(I) = (X(I)-DDOT(I-1,W(I,1),MDW,X,1))/W(I,I) + 180 CONTINUE +C +C Compute residuals for reduced problem. +C + MEP1 = ME + 1 + RNORML = 0.D0 + DO 190 I = MEP1,M + W(I,NP1) = W(I,NP1) - DDOT(KRANKE,W(I,1),MDW,X,1) + SN = DDOT(KRANKE,W(I,1),MDW,W(I,1),MDW) + RN = DDOT(N-KRANKE,W(I,KRANKE+1),MDW,W(I,KRANKE+1),MDW) + IF (RN.LE.SN*TAU**2 .AND. KRANKE.LT.N) + * CALL DCOPY (N-KRANKE, 0.D0, 0, W(I,KRANKE+1), MDW) + 190 CONTINUE +C +C Compute equality constraint equations residual length. +C + RNORME = DNRM2(ME-KRANKE,W(KRANKE+1,NP1),1) +C +C Move reduced problem data upward if KRANKE.LT.ME. +C + IF (KRANKE.LT.ME) THEN + DO 200 J = 1,NP1 + CALL DCOPY (M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1) + 200 CONTINUE + ENDIF +C +C Compute solution of reduced problem. +C + CALL DLSI(W(KRANKE+1, KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT, + + X(KRANKE+1), RNORML, MODE, WS(N2), IP(2)) +C +C Test for consistency of equality constraints. +C + IF (ME.GT.0) THEN + MDEQC = 0 + XNRME = DASUM(KRANKE,W(1,NP1),1) + IF (RNORME.GT.TAU*(ENORM*XNRME+FNORM)) MDEQC = 1 + MODE = MODE + MDEQC +C +C Check if solution to equality constraints satisfies inequality +C constraints when there are no degrees of freedom left. +C + IF (KRANKE.EQ.N .AND. MG.GT.0) THEN + XNORM = DASUM(N,X,1) + MAPKE1 = MA + KRANKE + 1 + MEND = MA + KRANKE + MG + DO 210 I = MAPKE1,MEND + SIZE = DASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1)) + IF (W(I,NP1).GT.TAU*SIZE) THEN + MODE = MODE + 2 + GO TO 290 + ENDIF + 210 CONTINUE + ENDIF + ENDIF +C +C Replace diagonal terms of lower trapezoidal matrix. +C + IF (KRANKE.GT.0) THEN + CALL DCOPY (KRANKE, WS(KRANKE+1), 1, W, MDW+1) +C +C Reapply transformation to put solution in original coordinates. +C + DO 220 I = KRANKE,1,-1 + CALL DH12 (2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1) + 220 CONTINUE +C +C Compute covariance matrix of equality constrained problem. +C + IF (COV) THEN + DO 270 J = MIN(KRANKE,N-1),1,-1 + RB = WS(J)*W(J,J) + IF (RB.NE.0.D0) RB = 1.D0/RB + JP1 = J + 1 + DO 230 I = JP1,N + W(I,J) = RB*DDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW) + 230 CONTINUE +C + GAM = 0.5D0*RB*DDOT(N-J,W(JP1,J),1,W(J,JP1),MDW) + CALL DAXPY (N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1) + DO 250 I = JP1,N + DO 240 K = I,N + W(I,K) = W(I,K) + W(J,I)*W(K,J) + W(I,J)*W(J,K) + W(K,I) = W(I,K) + 240 CONTINUE + 250 CONTINUE + UJ = WS(J) + VJ = GAM*UJ + W(J,J) = UJ*VJ + UJ*VJ + DO 260 I = JP1,N + W(J,I) = UJ*W(I,J) + VJ*W(J,I) + 260 CONTINUE + CALL DCOPY (N-J, W(J, JP1), MDW, W(JP1,J), 1) + 270 CONTINUE + ENDIF + ENDIF +C +C Apply the scaling to the covariance matrix. +C + IF (COV) THEN + DO 280 I = 1,N + CALL DSCAL (N, WS(I+N1-1), W(I,1), MDW) + CALL DSCAL (N, WS(I+N1-1), W(1,I), 1) + 280 CONTINUE + ENDIF +C +C Rescale solution vector. +C + 290 IF (MODE.LE.1) THEN + DO 300 J = 1,N + X(J) = X(J)*WS(N1+J-1) + 300 CONTINUE + ENDIF +C + IP(1) = KRANKE + IP(3) = IP(3) + 2*KRANKE + N + RETURN + END +*DECK DLSI + SUBROUTINE DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, + + IP) +C***BEGIN PROLOGUE DLSI +C***SUBSIDIARY +C***PURPOSE Subsidiary to DLSEI +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (LSI-S, DLSI-D) +C***AUTHOR Hanson, R. J., (SNLA) +C***DESCRIPTION +C +C This is a companion subprogram to DLSEI. The documentation for +C DLSEI has complete usage instructions. +C +C Solve.. +C AX = B, A MA by N (least squares equations) +C subject to.. +C +C GX.GE.H, G MG by N (inequality constraints) +C +C Input.. +C +C W(*,*) contains (A B) in rows 1,...,MA+MG, cols 1,...,N+1. +C (G H) +C +C MDW,MA,MG,N +C contain (resp) var. dimension of W(*,*), +C and matrix dimensions. +C +C PRGOPT(*), +C Program option vector. +C +C OUTPUT.. +C +C X(*),RNORM +C +C Solution vector(unless MODE=2), length of AX-B. +C +C MODE +C =0 Inequality constraints are compatible. +C =2 Inequality constraints contradictory. +C +C WS(*), +C Working storage of dimension K+N+(MG+2)*(N+7), +C where K=MAX(MA+MG,N). +C IP(MG+2*N+1) +C Integer working storage +C +C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, +C DLPDP, DSCAL, DSWAP +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and extensively revised (WRB & RWC) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900604 DP version created from SP version. (RWC) +C 920422 Changed CALL to DHFTI to include variable MA. (WRB) +C***END PROLOGUE DLSI + + INTEGER IP(*), MA, MDW, MG, MODE, N + DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*) +C + EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, DLPDP, + * DSCAL, DSWAP + DOUBLE PRECISION D1MACH, DASUM, DDOT +C + DOUBLE PRECISION ANORM, DRELPR, FAC, GAM, RB, TAU, TOL, XNORM, + * TMP_NORM(1) + INTEGER I, J, K, KEY, KRANK, KRM1, KRP1, L, LAST, LINK, M, MAP1, + * MDLPDP, MINMAN, N1, N2, N3, NEXT, NP1 + LOGICAL COV, FIRST, SCLCOV +C + SAVE DRELPR, FIRST + DATA FIRST /.TRUE./ +C +C***FIRST EXECUTABLE STATEMENT DLSI +C +C Set the nominal tolerance used in the code. +C + IF (FIRST) DRELPR = D1MACH(4) + FIRST = .FALSE. + TOL = SQRT(DRELPR) +C + MODE = 0 + RNORM = 0.D0 + M = MA + MG + NP1 = N + 1 + KRANK = 0 + IF (N.LE.0 .OR. M.LE.0) GO TO 370 +C +C To process option vector. +C + COV = .FALSE. + SCLCOV = .TRUE. + LAST = 1 + LINK = PRGOPT(1) +C + 100 IF (LINK.GT.1) THEN + KEY = PRGOPT(LAST+1) + IF (KEY.EQ.1) COV = PRGOPT(LAST+2) .NE. 0.D0 + IF (KEY.EQ.10) SCLCOV = PRGOPT(LAST+2) .EQ. 0.D0 + IF (KEY.EQ.5) TOL = MAX(DRELPR,PRGOPT(LAST+2)) + NEXT = PRGOPT(LINK) + LAST = LINK + LINK = NEXT + GO TO 100 + ENDIF +C +C Compute matrix norm of least squares equations. +C + ANORM = 0.D0 + DO 110 J = 1,N + ANORM = MAX(ANORM,DASUM(MA,W(1,J),1)) + 110 CONTINUE +C +C Set tolerance for DHFTI( ) rank test. +C + TAU = TOL*ANORM +C +C Compute Householder orthogonal decomposition of matrix. +C + CALL DCOPY (N, 0.D0, 0, WS, 1) + CALL DCOPY (MA, W(1, NP1), 1, WS, 1) + K = MAX(M,N) + MINMAN = MIN(MA,N) + N1 = K + 1 + N2 = N1 + N + CALL DHFTI (W, MDW, MA, N, WS, MA, 1, TAU, KRANK, TMP_NORM, + + WS(N2), WS(N1), IP) + RNORM = TMP_NORM(1) + FAC = 1.D0 + GAM = MA - KRANK + IF (KRANK.LT.MA .AND. SCLCOV) FAC = RNORM**2/GAM +C +C Reduce to DLPDP and solve. +C + MAP1 = MA + 1 +C +C Compute inequality rt-hand side for DLPDP. +C + IF (MA.LT.M) THEN + IF (MINMAN.GT.0) THEN + DO 120 I = MAP1,M + W(I,NP1) = W(I,NP1) - DDOT(N,W(I,1),MDW,WS,1) + 120 CONTINUE +C +C Apply permutations to col. of inequality constraint matrix. +C + DO 130 I = 1,MINMAN + CALL DSWAP (MG, W(MAP1,I), 1, W(MAP1,IP(I)), 1) + 130 CONTINUE +C +C Apply Householder transformations to constraint matrix. +C + IF (KRANK.GT.0 .AND. KRANK.LT.N) THEN + DO 140 I = KRANK,1,-1 + CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), + + W(MAP1,1), MDW, 1, MG) + 140 CONTINUE + ENDIF +C +C Compute permuted inequality constraint matrix times r-inv. +C + DO 160 I = MAP1,M + DO 150 J = 1,KRANK + W(I,J) = (W(I,J)-DDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J) + 150 CONTINUE + 160 CONTINUE + ENDIF +C +C Solve the reduced problem with DLPDP algorithm, +C the least projected distance problem. +C + CALL DLPDP(W(MAP1,1), MDW, MG, KRANK, N-KRANK, PRGOPT, X, + + XNORM, MDLPDP, WS(N2), IP(N+1)) +C +C Compute solution in original coordinates. +C + IF (MDLPDP.EQ.1) THEN + DO 170 I = KRANK,1,-1 + X(I) = (X(I)-DDOT(KRANK-I,W(I,I+1),MDW,X(I+1),1))/W(I,I) + 170 CONTINUE +C +C Apply Householder transformation to solution vector. +C + IF (KRANK.LT.N) THEN + DO 180 I = 1,KRANK + CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), + + X, 1, 1, 1) + 180 CONTINUE + ENDIF +C +C Repermute variables to their input order. +C + IF (MINMAN.GT.0) THEN + DO 190 I = MINMAN,1,-1 + CALL DSWAP (1, X(I), 1, X(IP(I)), 1) + 190 CONTINUE +C +C Variables are now in original coordinates. +C Add solution of unconstrained problem. +C + DO 200 I = 1,N + X(I) = X(I) + WS(I) + 200 CONTINUE +C +C Compute the residual vector norm. +C + RNORM = SQRT(RNORM**2+XNORM**2) + ENDIF + ELSE + MODE = 2 + ENDIF + ELSE + CALL DCOPY (N, WS, 1, X, 1) + ENDIF +C +C Compute covariance matrix based on the orthogonal decomposition +C from DHFTI( ). +C + IF (.NOT.COV .OR. KRANK.LE.0) GO TO 370 + KRM1 = KRANK - 1 + KRP1 = KRANK + 1 +C +C Copy diagonal terms to working array. +C + CALL DCOPY (KRANK, W, MDW+1, WS(N2), 1) +C +C Reciprocate diagonal terms. +C + DO 210 J = 1,KRANK + W(J,J) = 1.D0/W(J,J) + 210 CONTINUE +C +C Invert the upper triangular QR factor on itself. +C + IF (KRANK.GT.1) THEN + DO 230 I = 1,KRM1 + DO 220 J = I+1,KRANK + W(I,J) = -DDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J) + 220 CONTINUE + 230 CONTINUE + ENDIF +C +C Compute the inverted factor times its transpose. +C + DO 250 I = 1,KRANK + DO 240 J = I,KRANK + W(I,J) = DDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW) + 240 CONTINUE + 250 CONTINUE +C +C Zero out lower trapezoidal part. +C Copy upper triangular to lower triangular part. +C + IF (KRANK.LT.N) THEN + DO 260 J = 1,KRANK + CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) + 260 CONTINUE +C + DO 270 I = KRP1,N + CALL DCOPY (I, 0.D0, 0, W(I,1), MDW) + 270 CONTINUE +C +C Apply right side transformations to lower triangle. +C + N3 = N2 + KRP1 + DO 330 I = 1,KRANK + L = N1 + I + K = N2 + I + RB = WS(L-1)*WS(K-1) +C +C If RB.GE.0.D0, transformation can be regarded as zero. +C + IF (RB.LT.0.D0) THEN + RB = 1.D0/RB +C +C Store unscaled rank one Householder update in work array. +C + CALL DCOPY (N, 0.D0, 0, WS(N3), 1) + L = N1 + I + K = N3 + I + WS(K-1) = WS(L-1) +C + DO 280 J = KRP1,N + WS(N3+J-1) = W(I,J) + 280 CONTINUE +C + DO 290 J = 1,N + WS(J) = RB*(DDOT(J-I,W(J,I),MDW,WS(N3+I-1),1)+ + + DDOT(N-J+1,W(J,J),1,WS(N3+J-1),1)) + 290 CONTINUE +C + L = N3 + I + GAM = 0.5D0*RB*DDOT(N-I+1,WS(L-1),1,WS(I),1) + CALL DAXPY (N-I+1, GAM, WS(L-1), 1, WS(I), 1) + DO 320 J = I,N + DO 300 L = 1,I-1 + W(J,L) = W(J,L) + WS(N3+J-1)*WS(L) + 300 CONTINUE +C + DO 310 L = I,J + W(J,L) = W(J,L) + WS(J)*WS(N3+L-1)+WS(L)*WS(N3+J-1) + 310 CONTINUE + 320 CONTINUE + ENDIF + 330 CONTINUE +C +C Copy lower triangle to upper triangle to symmetrize the +C covariance matrix. +C + DO 340 I = 1,N + CALL DCOPY (I, W(I,1), MDW, W(1,I), 1) + 340 CONTINUE + ENDIF +C +C Repermute rows and columns. +C + DO 350 I = MINMAN,1,-1 + K = IP(I) + IF (I.NE.K) THEN + CALL DSWAP (1, W(I,I), 1, W(K,K), 1) + CALL DSWAP (I-1, W(1,I), 1, W(1,K), 1) + CALL DSWAP (K-I-1, W(I,I+1), MDW, W(I+1,K), 1) + CALL DSWAP (N-K, W(I, K+1), MDW, W(K, K+1), MDW) + ENDIF + 350 CONTINUE +C +C Put in normalized residual sum of squares scale factor +C and symmetrize the resulting covariance matrix. +C + DO 360 J = 1,N + CALL DSCAL (J, FAC, W(1,J), 1) + CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) + 360 CONTINUE +C + 370 IP(1) = KRANK + IP(2) = N + MAX(M,N) + (MG+2)*(N+7) + RETURN + END +*DECK D1MACH + DOUBLE PRECISION FUNCTION D1MACH (I) +C***BEGIN PROLOGUE D1MACH +C***PURPOSE Return floating point machine dependent constants. +C***LIBRARY SLATEC +C***CATEGORY R1 +C***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) +C***KEYWORDS MACHINE CONSTANTS +C***AUTHOR Fox, P. A., (Bell Labs) +C Hall, A. D., (Bell Labs) +C Schryer, N. L., (Bell Labs) +C***DESCRIPTION +C +C D1MACH can be used to obtain machine-dependent parameters for the +C local machine environment. It is a function subprogram with one +C (input) argument, and can be referenced as follows: +C +C D = D1MACH(I) +C +C where I=1,...,5. The (output) value of D above is determined by +C the (input) value of I. The results for various values of I are +C discussed below. +C +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 Assume double precision numbers are represented in the T-digit, +C base-B form +C +C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and +C EMIN .LE. E .LE. EMAX. +C +C The values of B, T, EMIN and EMAX are provided in I1MACH as +C follows: +C I1MACH(10) = B, the base. +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 +C To alter this function for a particular environment, the desired +C set of DATA statements should be activated by removing the C from +C column 1. Also, the values of D1MACH(1) - D1MACH(4) should be +C checked for consistency with the local operating system. +C +C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +C a portable library, ACM Transactions on Mathematical +C Software 4, 2 (June 1978), pp. 177-188. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 890213 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900618 Added DEC RISC constants. (WRB) +C 900723 Added IBM RS 6000 constants. (WRB) +C 900911 Added SUN 386i constants. (WRB) +C 910710 Added HP 730 constants. (SMR) +C 911114 Added Convex IEEE constants. (WRB) +C 920121 Added SUN -r8 compiler option constants. (WRB) +C 920229 Added Touchstone Delta i860 constants. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 920625 Added CONVEX -p8 and -pd8 compiler option constants. +C (BKS, WRB) +C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) +C 010817 Elevated IEEE to highest importance; see next set of +C comments below. (DWL) +C***END PROLOGUE D1MACH +C + + INTEGER SMALL(4) + INTEGER LARGE(4) + INTEGER RIGHT(4) + INTEGER DIVER(4) + INTEGER LOG10(4) +C +C Initial data here correspond to the IEEE standard. The values for +C DMACH(1), DMACH(3) and DMACH(4) are slight upper bounds. The value +C for DMACH(2) is a slight lower bound. The value for DMACH(5) is +C a 20-digit approximation. If one of the sets of initial data below +C is preferred, do the necessary commenting and uncommenting. (DWL) + DOUBLE PRECISION DMACH(5) + DATA DMACH / 2.23D-308, 1.79D+308, 1.111D-16, 2.222D-16, + 1 0.30102999566398119521D0 / + SAVE DMACH +C + 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 AMIGA +C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE APOLLO +C +C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / +C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / +C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / +C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM +C +C DATA SMALL(1) / ZC00800000 / +C DATA SMALL(2) / Z000000000 / +C DATA LARGE(1) / ZDFFFFFFFF / +C DATA LARGE(2) / ZFFFFFFFFF / +C DATA RIGHT(1) / ZCC5800000 / +C DATA RIGHT(2) / Z000000000 / +C DATA DIVER(1) / ZCC6800000 / +C DATA DIVER(2) / Z000000000 / +C DATA LOG10(1) / ZD00E730E7 / +C DATA LOG10(2) / ZC77800DC0 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O0000000000000000 / +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O0007777777777777 / +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O7770000000000000 / +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O7777777777777777 / +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 / +C +C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE +C +C DATA SMALL(1) / Z"3001800000000000" / +C DATA SMALL(2) / Z"3001000000000000" / +C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / +C DATA LARGE(2) / Z"4FFE000000000000" / +C DATA RIGHT(1) / Z"3FD2800000000000" / +C DATA RIGHT(2) / Z"3FD2000000000000" / +C DATA DIVER(1) / Z"3FD3800000000000" / +C DATA DIVER(2) / Z"3FD3000000000000" / +C DATA LOG10(1) / Z"3FFF9A209A84FBCF" / +C DATA LOG10(2) / Z"3FFFF7988F8959AC" / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES +C +C DATA SMALL(1) / 00564000000000000000B / +C DATA SMALL(2) / 00000000000000000000B / +C DATA LARGE(1) / 37757777777777777777B / +C DATA LARGE(2) / 37157777777777777777B / +C DATA RIGHT(1) / 15624000000000000000B / +C DATA RIGHT(2) / 00000000000000000000B / +C DATA DIVER(1) / 15634000000000000000B / +C DATA DIVER(2) / 00000000000000000000B / +C DATA LOG10(1) / 17164642023241175717B / +C DATA LOG10(2) / 16367571421742254654B / +C +C MACHINE CONSTANTS FOR THE CELERITY C1260 +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fn OR -pd8 COMPILER OPTION +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CC0000000000000' / +C DATA DMACH(4) / Z'3CD0000000000000' / +C DATA DMACH(5) / Z'3FF34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fi COMPILER OPTION +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -p8 COMPILER OPTION +C +C DATA DMACH(1) / Z'00010000000000000000000000000000' / +C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3F900000000000000000000000000000' / +C DATA DMACH(4) / Z'3F910000000000000000000000000000' / +C DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / +C +C MACHINE CONSTANTS FOR THE CRAY +C +C DATA SMALL(1) / 201354000000000000000B / +C DATA SMALL(2) / 000000000000000000000B / +C DATA LARGE(1) / 577767777777777777777B / +C DATA LARGE(2) / 000007777777777777774B / +C DATA RIGHT(1) / 376434000000000000000B / +C DATA RIGHT(2) / 000000000000000000000B / +C DATA DIVER(1) / 376444000000000000000B / +C DATA DIVER(2) / 000000000000000000000B / +C DATA LOG10(1) / 377774642023241175717B / +C DATA LOG10(2) / 000007571421742254654B / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - +C STATIC DMACH(5) +C +C DATA SMALL / 20K, 3*0 / +C DATA LARGE / 77777K, 3*177777K / +C DATA RIGHT / 31420K, 3*0 / +C DATA DIVER / 32020K, 3*0 / +C DATA LOG10 / 40423K, 42023K, 50237K, 74776K / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING G_FLOAT +C +C DATA DMACH(1) / '0000000000000010'X / +C DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / +C DATA DMACH(3) / '0000000000003CC0'X / +C DATA DMACH(4) / '0000000000003CD0'X / +C DATA DMACH(5) / '79FF509F44133FF3'X / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING IEEE_FORMAT +C +C DATA DMACH(1) / '0010000000000000'X / +C DATA DMACH(2) / '7FEFFFFFFFFFFFFF'X / +C DATA DMACH(3) / '3CA0000000000000'X / +C DATA DMACH(4) / '3CB0000000000000'X / +C DATA DMACH(5) / '3FD34413509F79FF'X / +C +C MACHINE CONSTANTS FOR THE DEC RISC +C +C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ +C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ +C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ +C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ +C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING D_FLOATING +C (EXPRESSED IN INTEGER AND HEXADECIMAL) +C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS +C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS +C +C DATA SMALL(1), SMALL(2) / 128, 0 / +C DATA LARGE(1), LARGE(2) / -32769, -1 / +C DATA RIGHT(1), RIGHT(2) / 9344, 0 / +C DATA DIVER(1), DIVER(2) / 9472, 0 / +C DATA LOG10(1), LOG10(2) / 546979738, -805796613 / +C +C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / +C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING G_FLOATING +C (EXPRESSED IN INTEGER AND HEXADECIMAL) +C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS +C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS +C +C DATA SMALL(1), SMALL(2) / 16, 0 / +C DATA LARGE(1), LARGE(2) / -32769, -1 / +C DATA RIGHT(1), RIGHT(2) / 15552, 0 / +C DATA DIVER(1), DIVER(2) / 15568, 0 / +C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / +C +C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / +C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / +C +C MACHINE CONSTANTS FOR THE ELXSI 6400 +C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) +C +C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / +C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / +C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / +C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / +C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / +C +C MACHINE CONSTANTS FOR THE HARRIS 220 +C +C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / +C DATA LARGE(1), LARGE(2) / '37777777, '37777577 / +C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / +C DATA DIVER(1), DIVER(2) / '20000000, '00000334 / +C DATA LOG10(1), LOG10(2) / '23210115, '10237777 / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES +C +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 / +C +C MACHINE CONSTANTS FOR THE HP 730 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / +C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / +C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / +C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / +C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA SMALL(1), SMALL(2) / 40000B, 0 / +C DATA SMALL(3), SMALL(4) / 0, 1 / +C DATA LARGE(1), LARGE(2) / 77777B, 177777B / +C DATA LARGE(3), LARGE(4) / 177777B, 177776B / +C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / +C DATA RIGHT(3), RIGHT(4) / 0, 225B / +C DATA DIVER(1), DIVER(2) / 40000B, 0 / +C DATA DIVER(3), DIVER(4) / 0, 227B / +C DATA LOG10(1), LOG10(2) / 46420B, 46502B / +C DATA LOG10(3), LOG10(4) / 76747B, 176377B / +C +C MACHINE CONSTANTS FOR THE HP 9000 +C +C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / +C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / +C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / +C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / +C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND +C THE PERKIN ELMER (INTERDATA) 7/32. +C +C DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / +C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / +C +C MACHINE CONSTANTS FOR THE IBM PC +C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION +C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. +C +C DATA SMALL(1) / 2.23D-308 / +C DATA LARGE(1) / 1.79D+308 / +C DATA RIGHT(1) / 1.11D-16 / +C DATA DIVER(1) / 2.22D-16 / +C DATA LOG10(1) / 0.301029995663981195D0 / +C +C MACHINE CONSTANTS FOR THE IBM RS 6000 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE INTEL i860 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) +C +C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / +C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / +C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / +C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / +C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) +C +C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / +C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / +C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / +C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / +C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +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 / +C +C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / +C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / +C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / +C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / +C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA SMALL(1), SMALL(2) / 128, 0 / +C DATA SMALL(3), SMALL(4) / 0, 0 / +C DATA LARGE(1), LARGE(2) / 32767, -1 / +C DATA LARGE(3), LARGE(4) / -1, -1 / +C DATA RIGHT(1), RIGHT(2) / 9344, 0 / +C DATA RIGHT(3), RIGHT(4) / 0, 0 / +C DATA DIVER(1), DIVER(2) / 9472, 0 / +C DATA DIVER(3), DIVER(4) / 0, 0 / +C DATA LOG10(1), LOG10(2) / 16282, 8346 / +C DATA LOG10(3), LOG10(4) / -31493, -12296 / +C +C DATA SMALL(1), SMALL(2) / O000200, O000000 / +C DATA SMALL(3), SMALL(4) / O000000, O000000 / +C DATA LARGE(1), LARGE(2) / O077777, O177777 / +C DATA LARGE(3), LARGE(4) / O177777, O177777 / +C DATA RIGHT(1), RIGHT(2) / O022200, O000000 / +C DATA RIGHT(3), RIGHT(4) / O000000, O000000 / +C DATA DIVER(1), DIVER(2) / O022400, O000000 / +C DATA DIVER(3), DIVER(4) / O000000, O000000 / +C DATA LOG10(1), LOG10(2) / O037632, O020232 / +C DATA LOG10(3), LOG10(4) / O102373, O147770 / +C +C MACHINE CONSTANTS FOR THE SILICON GRAPHICS +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE SUN +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE SUN +C USING THE -r8 COMPILER OPTION +C +C DATA DMACH(1) / Z'00010000000000000000000000000000' / +C DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / +C DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / +C DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / +C +C MACHINE CONSTANTS FOR THE SUN 386i +C +C DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / +C DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / +C DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' +C DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER +C +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 / +C +C***FIRST EXECUTABLE STATEMENT D1MACH +C IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'D1MACH', +C + 'I OUT OF BOUNDS', 1, 2) +C + D1MACH = DMACH(I) + RETURN +C + END +*DECK I1MACH + INTEGER FUNCTION I1MACH (I) +C***BEGIN PROLOGUE I1MACH +C***PURPOSE Return integer machine dependent constants. +C***LIBRARY SLATEC +C***CATEGORY R1 +C***TYPE INTEGER (I1MACH-I) +C***KEYWORDS MACHINE CONSTANTS +C***AUTHOR Fox, P. A., (Bell Labs) +C Hall, A. D., (Bell Labs) +C Schryer, N. L., (Bell Labs) +C***DESCRIPTION +C +C I1MACH can be used to obtain machine-dependent parameters for the +C local machine environment. It is a function subprogram with one +C (input) argument and can be referenced as follows: +C +C K = I1MACH(I) +C +C where I=1,...,16. The (output) value of K above is determined by +C the (input) value of I. The results for various values of I are +C discussed below. +C +C I/O unit numbers: +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 +C Words: +C I1MACH( 5) = the number of bits per integer storage unit. +C I1MACH( 6) = the number of characters per integer storage unit. +C +C Integers: +C assume integers are represented in the S-digit, base-A form +C +C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) +C +C where 0 .LE. X(I) .LT. A for I=0,...,S-1. +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 +C Floating-Point Numbers: +C Assume floating-point numbers are represented in the T-digit, +C base-B form +C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C where 0 .LE. X(I) .LT. B for I=1,...,T, +C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. +C I1MACH(10) = B, the base. +C +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 +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 +C To alter this function for a particular environment, the desired +C set of DATA statements should be activated by removing the C from +C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be +C checked for consistency with the local operating system. +C +C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +C a portable library, ACM Transactions on Mathematical +C Software 4, 2 (June 1978), pp. 177-188. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 891012 Added VAX G-floating constants. (WRB) +C 891012 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900618 Added DEC RISC constants. (WRB) +C 900723 Added IBM RS 6000 constants. (WRB) +C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. +C (RWC) +C 910710 Added HP 730 constants. (SMR) +C 911114 Added Convex IEEE constants. (WRB) +C 920121 Added SUN -r8 compiler option constants. (WRB) +C 920229 Added Touchstone Delta i860 constants. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 920625 Added Convex -p8 and -pd8 compiler option constants. +C (BKS, WRB) +C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) +C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler +C options. (DWL, RWC and WRB). +C 010817 Elevated IEEE to highest importance; see next set of +C comments below. (DWL) +C***END PROLOGUE I1MACH +C +C Initial data here correspond to the IEEE standard. If one of the +C sets of initial data below is preferred, do the necessary commenting +C and uncommenting. (DWL) + INTEGER IMACH(16),OUTPUT + DATA IMACH( 1) / 5 / + DATA IMACH( 2) / 6 / + DATA IMACH( 3) / 6 / + DATA IMACH( 4) / 6 / + DATA IMACH( 5) / 32 / + DATA IMACH( 6) / 4 / + DATA IMACH( 7) / 2 / + DATA IMACH( 8) / 31 / + DATA IMACH( 9) / 2147483647 / + DATA IMACH(10) / 2 / + DATA IMACH(11) / 24 / + DATA IMACH(12) / -126 / + DATA IMACH(13) / 127 / + DATA IMACH(14) / 53 / + DATA IMACH(15) / -1022 / + DATA IMACH(16) / 1023 / + SAVE IMACH + EQUIVALENCE (IMACH(4),OUTPUT) +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT COMPILER +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE APOLLO +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 129 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1025 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM +C +C DATA IMACH( 1) / 7 / +C DATA IMACH( 2) / 2 / +C DATA IMACH( 3) / 2 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 33 / +C DATA IMACH( 9) / Z1FFFFFFFF / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -256 / +C DATA IMACH(13) / 255 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) / -256 / +C DATA IMACH(16) / 255 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM +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) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -50 / +C DATA IMACH(16) / 76 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS +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) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -32754 / +C DATA IMACH(16) / 32780 / +C +C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE +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) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -4095 / +C DATA IMACH(13) / 4094 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -4095 / +C DATA IMACH(16) / 4094 / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6LOUTPUT/ +C DATA IMACH( 5) / 60 / +C DATA IMACH( 6) / 10 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 48 / +C DATA IMACH( 9) / 00007777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -929 / +C DATA IMACH(13) / 1070 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -929 / +C DATA IMACH(16) / 1069 / +C +C MACHINE CONSTANTS FOR THE CELERITY C1260 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 0 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / Z'7FFFFFFF' / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fn COMPILER OPTION +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) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fi COMPILER OPTION +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -p8 COMPILER OPTION +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) / 64 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1023 / +C DATA IMACH(13) / 1023 / +C DATA IMACH(14) / 113 / +C DATA IMACH(15) / -16383 / +C DATA IMACH(16) / 16383 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -pd8 COMPILER OPTION +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) / 64 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1023 / +C DATA IMACH(13) / 1023 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CRAY +C USING THE 46 BIT INTEGER COMPILER OPTION +C +C DATA IMACH( 1) / 100 / +C DATA IMACH( 2) / 101 / +C DATA IMACH( 3) / 102 / +C DATA IMACH( 4) / 101 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 46 / +C DATA IMACH( 9) / 1777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -8189 / +C DATA IMACH(13) / 8190 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -8099 / +C DATA IMACH(16) / 8190 / +C +C MACHINE CONSTANTS FOR THE CRAY +C USING THE 64 BIT INTEGER COMPILER OPTION +C +C DATA IMACH( 1) / 100 / +C DATA IMACH( 2) / 101 / +C DATA IMACH( 3) / 102 / +C DATA IMACH( 4) / 101 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 777777777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -8189 / +C DATA IMACH(13) / 8190 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -8099 / +C DATA IMACH(16) / 8190 / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C +C DATA IMACH( 1) / 11 / +C DATA IMACH( 2) / 12 / +C DATA IMACH( 3) / 8 / +C DATA IMACH( 4) / 10 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING G_FLOAT +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING IEEE_FLOAT +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE DEC RISC +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING D_FLOATING +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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 / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING G_FLOATING +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE ELXSI 6400 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 32 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE HARRIS 220 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / 3 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 23 / +C DATA IMACH( 9) / 8388607 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 38 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 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) / 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) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 63 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 730 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 4 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 39 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 4 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 55 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 9000 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 7 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 32 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1015 / +C DATA IMACH(16) / 1017 / +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND +C THE PERKIN ELMER (INTERDATA) 7/32. +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) / Z7FFFFFFF / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 / +C +C MACHINE CONSTANTS FOR THE IBM PC +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 0 / +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) / -125 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE IBM RS 6000 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 0 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE INTEL i860 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 54 / +C DATA IMACH(15) / -101 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 62 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 16-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +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 / +C +C MACHINE CONSTANTS FOR THE SILICON GRAPHICS +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE SUN +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE SUN +C USING THE -r8 COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / 53 / +C DATA IMACH(12) / -1021 / +C DATA IMACH(13) / 1024 / +C DATA IMACH(14) / 113 / +C DATA IMACH(15) / -16381 / +C DATA IMACH(16) / 16384 / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 1 / +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) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) / -1024 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR +C +C DATA IMACH( 1) / 1 / +C DATA IMACH( 2) / 1 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +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 / +C +C***FIRST EXECUTABLE STATEMENT I1MACH + IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 +C + I1MACH = IMACH(I) + RETURN +C + 10 CONTINUE + WRITE (UNIT = OUTPUT, FMT = 9000) + 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') +C +C CALL FDUMP +C + STOP + END +*DECK DH12 + SUBROUTINE DH12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV, + + NCV) +C***BEGIN PROLOGUE DH12 +C***SUBSIDIARY +C***PURPOSE Subsidiary to DHFTI, DLSEI and DWNNLS +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (H12-S, DH12-D) +C***AUTHOR (UNKNOWN) +C***DESCRIPTION +C +C *** DOUBLE PRECISION VERSION OF H12 ****** +C +C C.L.Lawson and R.J.Hanson, Jet Propulsion Laboratory, 1973 Jun 12 +C to appear in 'Solving Least Squares Problems', Prentice-Hall, 1974 +C +C Construction and/or application of a single +C Householder transformation.. Q = I + U*(U**T)/B +C +C MODE = 1 or 2 to select algorithm H1 or H2 . +C LPIVOT is the index of the pivot element. +C L1,M If L1 .LE. M the transformation will be constructed to +C zero elements indexed from L1 through M. If L1 GT. M +C THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. +C U(),IUE,UP On entry to H1 U() contains the pivot vector. +C IUE is the storage increment between elements. +C On exit from H1 U() and UP +C contain quantities defining the vector U of the +C Householder transformation. On entry to H2 U() +C and UP should contain quantities previously computed +C by H1. These will not be modified by H2. +C C() On entry to H1 or H2 C() contains a matrix which will be +C regarded as a set of vectors to which the Householder +C transformation is to be applied. On exit C() contains the +C set of transformed vectors. +C ICE Storage increment between elements of vectors in C(). +C ICV Storage increment between vectors in C(). +C NCV Number of vectors in C() to be transformed. If NCV .LE. 0 +C no operations will be done on C(). +C +C***SEE ALSO DHFTI, DLSEI, DWNNLS +C***ROUTINES CALLED DAXPY, DDOT, DSWAP +C***REVISION HISTORY (YYMMDD) +C 790101 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900911 Added DDOT to DOUBLE PRECISION statement. (WRB) +C***END PROLOGUE DH12 + + INTEGER I, I2, I3, I4, ICE, ICV, INCR, IUE, J, KL1, KL2, KLP, + * L1, L1M1, LPIVOT, M, MML1P2, MODE, NCV + DOUBLE PRECISION B, C, CL, CLINV, ONE, UL1M1, SM, U, UP, DDOT + DIMENSION U(IUE,*), C(*) +C BEGIN BLOCK PERMITTING ...EXITS TO 140 +C***FIRST EXECUTABLE STATEMENT DH12 + ONE = 1.0D0 +C +C ...EXIT + IF (0 .GE. LPIVOT .OR. LPIVOT .GE. L1 .OR. L1 .GT. M) GO TO 140 + CL = ABS(U(1,LPIVOT)) + IF (MODE .EQ. 2) GO TO 40 +C ****** CONSTRUCT THE TRANSFORMATION. ****** + DO 10 J = L1, M + CL = MAX(ABS(U(1,J)),CL) + 10 CONTINUE + IF (CL .GT. 0.0D0) GO TO 20 +C .........EXIT + GO TO 140 + 20 CONTINUE + CLINV = ONE/CL + SM = (U(1,LPIVOT)*CLINV)**2 + DO 30 J = L1, M + SM = SM + (U(1,J)*CLINV)**2 + 30 CONTINUE + CL = CL*SQRT(SM) + IF (U(1,LPIVOT) .GT. 0.0D0) CL = -CL + UP = U(1,LPIVOT) - CL + U(1,LPIVOT) = CL + GO TO 50 + 40 CONTINUE +C ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** +C + IF (CL .GT. 0.0D0) GO TO 50 +C ......EXIT + GO TO 140 + 50 CONTINUE +C ...EXIT + IF (NCV .LE. 0) GO TO 140 + B = UP*U(1,LPIVOT) +C B MUST BE NONPOSITIVE HERE. IF B = 0., RETURN. +C + IF (B .LT. 0.0D0) GO TO 60 +C ......EXIT + GO TO 140 + 60 CONTINUE + B = ONE/B + MML1P2 = M - L1 + 2 + IF (MML1P2 .LE. 20) GO TO 80 + L1M1 = L1 - 1 + KL1 = 1 + (L1M1 - 1)*ICE + KL2 = KL1 + KLP = 1 + (LPIVOT - 1)*ICE + UL1M1 = U(1,L1M1) + U(1,L1M1) = UP + IF (LPIVOT .NE. L1M1) CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) + DO 70 J = 1, NCV + SM = DDOT(MML1P2,U(1,L1M1),IUE,C(KL1),ICE) + SM = SM*B + CALL DAXPY(MML1P2,SM,U(1,L1M1),IUE,C(KL1),ICE) + KL1 = KL1 + ICV + 70 CONTINUE + U(1,L1M1) = UL1M1 +C ......EXIT + IF (LPIVOT .EQ. L1M1) GO TO 140 + KL1 = KL2 + CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) + GO TO 130 + 80 CONTINUE + I2 = 1 - ICV + ICE*(LPIVOT - 1) + INCR = ICE*(L1 - LPIVOT) + DO 120 J = 1, NCV + I2 = I2 + ICV + I3 = I2 + INCR + I4 = I3 + SM = C(I2)*UP + DO 90 I = L1, M + SM = SM + C(I3)*U(1,I) + I3 = I3 + ICE + 90 CONTINUE + IF (SM .EQ. 0.0D0) GO TO 110 + SM = SM*B + C(I2) = C(I2) + SM*UP + DO 100 I = L1, M + C(I4) = C(I4) + SM*U(1,I) + I4 = I4 + ICE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + RETURN + END +*DECK DHFTI + SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, + + G, IP) +C***BEGIN PROLOGUE DHFTI +C***PURPOSE Solve a least squares problem for banded matrices using +C sequential accumulation of rows of the data matrix. +C Exactly one right-hand side vector is permitted. +C***LIBRARY SLATEC +C***CATEGORY D9 +C***TYPE DOUBLE PRECISION (HFTI-S, DHFTI-D) +C***KEYWORDS CURVE FITTING, LEAST SQUARES +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C***DESCRIPTION +C +C DIMENSION A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N) +C +C This subroutine solves a linear least squares problem or a set of +C linear least squares problems having the same matrix but different +C right-side vectors. The problem data consists of an M by N matrix +C A, an M by NB matrix B, and an absolute tolerance parameter TAU +C whose usage is described below. The NB column vectors of B +C represent right-side vectors for NB distinct linear least squares +C problems. +C +C This set of problems can also be written as the matrix least +C squares problem +C +C AX = B, +C +C where X is the N by NB solution matrix. +C +C Note that if B is the M by M identity matrix, then X will be the +C pseudo-inverse of A. +C +C This subroutine first transforms the augmented matrix (A B) to a +C matrix (R C) using premultiplying Householder transformations with +C column interchanges. All subdiagonal elements in the matrix R are +C zero and its diagonal elements satisfy +C +C ABS(R(I,I)).GE.ABS(R(I+1,I+1)), +C +C I = 1,...,L-1, where +C +C L = MIN(M,N). +C +C The subroutine will compute an integer, KRANK, equal to the number +C of diagonal terms of R that exceed TAU in magnitude. Then a +C solution of minimum Euclidean length is computed using the first +C KRANK rows of (R C). +C +C To be specific we suggest that the user consider an easily +C computable matrix norm, such as, the maximum of all column sums of +C magnitudes. +C +C Now if the relative uncertainty of B is EPS, (norm of uncertainty/ +C norm of B), it is suggested that TAU be set approximately equal to +C EPS*(norm of A). +C +C The user must dimension all arrays appearing in the call list.. +C A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N). This +C permits the solution of a range of problems in the same array +C space. +C +C The entire set of parameters for DHFTI are +C +C INPUT.. All TYPE REAL variables are DOUBLE PRECISION +C +C A(*,*),MDA,M,N The array A(*,*) initially contains the M by N +C matrix A of the least squares problem AX = B. +C The first dimensioning parameter of the array +C A(*,*) is MDA, which must satisfy MDA.GE.M +C Either M.GE.N or M.LT.N is permitted. There +C is no restriction on the rank of A. The +C condition MDA.LT.M is considered an error. +C +C B(*),MDB,NB If NB = 0 the subroutine will perform the +C orthogonal decomposition but will make no +C references to the array B(*). If NB.GT.0 +C the array B(*) must initially contain the M by +C NB matrix B of the least squares problem AX = +C B. If NB.GE.2 the array B(*) must be doubly +C subscripted with first dimensioning parameter +C MDB.GE.MAX(M,N). If NB = 1 the array B(*) may +C be either doubly or singly subscripted. In +C the latter case the value of MDB is arbitrary +C but it should be set to some valid integer +C value such as MDB = M. +C +C The condition of NB.GT.1.AND.MDB.LT. MAX(M,N) +C is considered an error. +C +C TAU Absolute tolerance parameter provided by user +C for pseudorank determination. +C +C H(*),G(*),IP(*) Arrays of working space used by DHFTI. +C +C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION +C +C A(*,*) The contents of the array A(*,*) will be +C modified by the subroutine. These contents +C are not generally required by the user. +C +C B(*) On return the array B(*) will contain the N by +C NB solution matrix X. +C +C KRANK Set by the subroutine to indicate the +C pseudorank of A. +C +C RNORM(*) On return, RNORM(J) will contain the Euclidean +C norm of the residual vector for the problem +C defined by the J-th column vector of the array +C B(*,*) for J = 1,...,NB. +C +C H(*),G(*) On return these arrays respectively contain +C elements of the pre- and post-multiplying +C Householder transformations used to compute +C the minimum Euclidean length solution. +C +C IP(*) Array in which the subroutine records indices +C describing the permutation of column vectors. +C The contents of arrays H(*),G(*) and IP(*) +C are not generally required by the user. +C +C***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares +C Problems, Prentice-Hall, Inc., 1974, Chapter 14. +C***ROUTINES CALLED D1MACH, DH12, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790101 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 891006 Cosmetic changes to prologue. (WRB) +C 891006 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 901005 Replace usage of DDIFF with usage of D1MACH. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DHFTI + + INTEGER I, II, IOPT, IP(*), IP1, J, JB, JJ, K, KP1, KRANK, L, + * LDIAG, LMAX, M, MDA, MDB, N, NB, NERR + DOUBLE PRECISION A, B, D1MACH, DZERO, FACTOR, + * G, H, HMAX, RELEPS, RNORM, SM, SM1, SZERO, TAU, TMP + DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*) + SAVE RELEPS + DATA RELEPS /0.D0/ +C BEGIN BLOCK PERMITTING ...EXITS TO 360 +C***FIRST EXECUTABLE STATEMENT DHFTI + IF (RELEPS.EQ.0.D0) RELEPS = D1MACH(4) + SZERO = 0.0D0 + DZERO = 0.0D0 + FACTOR = 0.001D0 +C + K = 0 + LDIAG = MIN(M,N) + IF (LDIAG .LE. 0) GO TO 350 +C BEGIN BLOCK PERMITTING ...EXITS TO 130 +C BEGIN BLOCK PERMITTING ...EXITS TO 120 + IF (MDA .GE. M) GO TO 10 + NERR = 1 + IOPT = 2 +C CALL XERMSG ('SLATEC', 'DHFTI', +C + 'MDA.LT.M, PROBABLE ERROR.', +C + NERR, IOPT) +C ...............EXIT + GO TO 360 + 10 CONTINUE +C + IF (NB .LE. 1 .OR. MAX(M,N) .LE. MDB) GO TO 20 + NERR = 2 + IOPT = 2 +C CALL XERMSG ('SLATEC', 'DHFTI', +C + 'MDB.LT.MAX(M,N).AND.NB.GT.1. PROBABLE ERROR.', +C + NERR, IOPT) +C ...............EXIT + GO TO 360 + 20 CONTINUE +C + DO 100 J = 1, LDIAG +C BEGIN BLOCK PERMITTING ...EXITS TO 70 + IF (J .EQ. 1) GO TO 40 +C +C UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX +C .. + LMAX = J + DO 30 L = J, N + H(L) = H(L) - A(J-1,L)**2 + IF (H(L) .GT. H(LMAX)) LMAX = L + 30 CONTINUE +C ......EXIT + IF (FACTOR*H(LMAX) .GT. HMAX*RELEPS) GO TO 70 + 40 CONTINUE +C +C COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX +C .. + LMAX = J + DO 60 L = J, N + H(L) = 0.0D0 + DO 50 I = J, M + H(L) = H(L) + A(I,L)**2 + 50 CONTINUE + IF (H(L) .GT. H(LMAX)) LMAX = L + 60 CONTINUE + HMAX = H(LMAX) + 70 CONTINUE +C .. +C LMAX HAS BEEN DETERMINED +C +C DO COLUMN INTERCHANGES IF NEEDED. +C .. + IP(J) = LMAX + IF (IP(J) .EQ. J) GO TO 90 + DO 80 I = 1, M + TMP = A(I,J) + A(I,J) = A(I,LMAX) + A(I,LMAX) = TMP + 80 CONTINUE + H(LMAX) = H(J) + 90 CONTINUE +C +C COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A +C AND B. +C .. + CALL DH12(1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA, + * N-J) + CALL DH12(2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB) + 100 CONTINUE +C +C DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, +C TAU. +C .. + DO 110 J = 1, LDIAG +C ......EXIT + IF (ABS(A(J,J)) .LE. TAU) GO TO 120 + 110 CONTINUE + K = LDIAG +C ......EXIT + GO TO 130 + 120 CONTINUE + K = J - 1 + 130 CONTINUE + KP1 = K + 1 +C +C COMPUTE THE NORMS OF THE RESIDUAL VECTORS. +C + IF (NB .LT. 1) GO TO 170 + DO 160 JB = 1, NB + TMP = SZERO + IF (M .LT. KP1) GO TO 150 + DO 140 I = KP1, M + TMP = TMP + B(I,JB)**2 + 140 CONTINUE + 150 CONTINUE + RNORM(JB) = SQRT(TMP) + 160 CONTINUE + 170 CONTINUE +C SPECIAL FOR PSEUDORANK = 0 + IF (K .GT. 0) GO TO 210 + IF (NB .LT. 1) GO TO 200 + DO 190 JB = 1, NB + DO 180 I = 1, N + B(I,JB) = SZERO + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + GO TO 340 + 210 CONTINUE +C +C IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER +C DECOMPOSITION OF FIRST K ROWS. +C .. + IF (K .EQ. N) GO TO 230 + DO 220 II = 1, K + I = KP1 - II + CALL DH12(1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1) + 220 CONTINUE + 230 CONTINUE +C +C + IF (NB .LT. 1) GO TO 330 + DO 320 JB = 1, NB +C +C SOLVE THE K BY K TRIANGULAR SYSTEM. +C .. + DO 260 L = 1, K + SM = DZERO + I = KP1 - L + IP1 = I + 1 + IF (K .LT. IP1) GO TO 250 + DO 240 J = IP1, K + SM = SM + A(I,J)*B(J,JB) + 240 CONTINUE + 250 CONTINUE + SM1 = SM + B(I,JB) = (B(I,JB) - SM1)/A(I,I) + 260 CONTINUE +C +C COMPLETE COMPUTATION OF SOLUTION VECTOR. +C .. + IF (K .EQ. N) GO TO 290 + DO 270 J = KP1, N + B(J,JB) = SZERO + 270 CONTINUE + DO 280 I = 1, K + CALL DH12(2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1, + * MDB,1) + 280 CONTINUE + 290 CONTINUE +C +C RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE +C COLUMN INTERCHANGES. +C .. + DO 310 JJ = 1, LDIAG + J = LDIAG + 1 - JJ + IF (IP(J) .EQ. J) GO TO 300 + L = IP(J) + TMP = B(L,JB) + B(L,JB) = B(J,JB) + B(J,JB) = TMP + 300 CONTINUE + 310 CONTINUE + 320 CONTINUE + 330 CONTINUE + 340 CONTINUE + 350 CONTINUE +C .. +C THE SOLUTION VECTORS, X, ARE NOW +C IN THE FIRST N ROWS OF THE ARRAY B(,). +C + KRANK = K + 360 CONTINUE + RETURN + END +*DECK DLPDP + SUBROUTINE DLPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, + + IS) +C***BEGIN PROLOGUE DLPDP +C***SUBSIDIARY +C***PURPOSE Subsidiary to DLSEI +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (LPDP-S, DLPDP-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C **** Double Precision version of LPDP **** +C DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1), +C where N=N1+N2. This is a slight overestimate for WS(*). +C +C Determine an N1-vector W, and +C an N2-vector Z +C which minimizes the Euclidean length of W +C subject to G*W+H*Z .GE. Y. +C This is the least projected distance problem, LPDP. +C The matrices G and H are of respective +C dimensions M by N1 and M by N2. +C +C Called by subprogram DLSI( ). +C +C The matrix +C (G H Y) +C +C occupies rows 1,...,M and cols 1,...,N1+N2+1 of A(*,*). +C +C The solution (W) is returned in X(*). +C (Z) +C +C The value of MODE indicates the status of +C the computation after returning to the user. +C +C MODE=1 The solution was successfully obtained. +C +C MODE=2 The inequalities are inconsistent. +C +C***SEE ALSO DLSEI +C***ROUTINES CALLED DCOPY, DDOT, DNRM2, DSCAL, DWNNLS +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910408 Updated the AUTHOR section. (WRB) +C***END PROLOGUE DLPDP + +C + INTEGER I, IS(*), IW, IX, J, L, M, MDA, MODE, MODEW, N, N1, N2, + * NP1 + DOUBLE PRECISION A(MDA,*), DDOT, DNRM2, FAC, ONE, + * PRGOPT(*), RNORM, SC, WNORM, WS(*), X(*), YNORM, ZERO + SAVE ZERO, ONE, FAC + DATA ZERO,ONE /0.0D0,1.0D0/, FAC /0.1D0/ +C***FIRST EXECUTABLE STATEMENT DLPDP + N = N1 + N2 + MODE = 1 + IF (M .GT. 0) GO TO 20 + IF (N .LE. 0) GO TO 10 + X(1) = ZERO + CALL DCOPY(N,X,0,X,1) + 10 CONTINUE + WNORM = ZERO + GO TO 200 + 20 CONTINUE +C BEGIN BLOCK PERMITTING ...EXITS TO 190 + NP1 = N + 1 +C +C SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE. + DO 40 I = 1, M + SC = DNRM2(N,A(I,1),MDA) + IF (SC .EQ. ZERO) GO TO 30 + SC = ONE/SC + CALL DSCAL(NP1,SC,A(I,1),MDA) + 30 CONTINUE + 40 CONTINUE +C +C SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO). + YNORM = DNRM2(M,A(1,NP1),1) + IF (YNORM .EQ. ZERO) GO TO 50 + SC = ONE/YNORM + CALL DSCAL(M,SC,A(1,NP1),1) + 50 CONTINUE +C +C SCALE COLS OF MATRIX H. + J = N1 + 1 + 60 IF (J .GT. N) GO TO 70 + SC = DNRM2(M,A(1,J),1) + IF (SC .NE. ZERO) SC = ONE/SC + CALL DSCAL(M,SC,A(1,J),1) + X(J) = SC + J = J + 1 + GO TO 60 + 70 CONTINUE + IF (N1 .LE. 0) GO TO 130 +C +C COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*). + IW = 0 + DO 80 I = 1, M +C +C MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY. + CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) + IW = IW + N2 +C +C MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY. + CALL DCOPY(N1,A(I,1),MDA,WS(IW+1),1) + IW = IW + N1 +C +C MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY. + WS(IW+1) = A(I,NP1) + IW = IW + 1 + 80 CONTINUE + WS(IW+1) = ZERO + CALL DCOPY(N,WS(IW+1),0,WS(IW+1),1) + IW = IW + N + WS(IW+1) = ONE + IW = IW + 1 +C +C SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0. THE +C MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR +C F = TRANSPOSE OF (0,...,0,1). + IX = IW + 1 + IW = IW + M +C +C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF +C DWNNLS( ). + IS(1) = 0 + IS(2) = 0 + CALL DWNNLS(WS,NP1,N2,NP1-N2,M,0,PRGOPT,WS(IX),RNORM, + * MODEW,IS,WS(IW+1)) +C +C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W. + SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) + IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) + * GO TO 110 + SC = ONE/SC + DO 90 J = 1, N1 + X(J) = SC*DDOT(M,A(1,J),1,WS(IX),1) + 90 CONTINUE +C +C COMPUTE THE VECTOR Q=Y-GW. OVERWRITE Y WITH THIS +C VECTOR. + DO 100 I = 1, M + A(I,NP1) = A(I,NP1) - DDOT(N1,A(I,1),MDA,X,1) + 100 CONTINUE + GO TO 120 + 110 CONTINUE + MODE = 2 +C .........EXIT + GO TO 190 + 120 CONTINUE + 130 CONTINUE + IF (N2 .LE. 0) GO TO 180 +C +C COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*). + IW = 0 + DO 140 I = 1, M + CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) + IW = IW + N2 + WS(IW+1) = A(I,NP1) + IW = IW + 1 + 140 CONTINUE + WS(IW+1) = ZERO + CALL DCOPY(N2,WS(IW+1),0,WS(IW+1),1) + IW = IW + N2 + WS(IW+1) = ONE + IW = IW + 1 + IX = IW + 1 + IW = IW + M +C +C SOLVE RV=S SUBJECT TO V.GE.0. THE MATRIX R =(TRANSPOSE +C OF (H Q)), WHERE Q=Y-GW. THE (N2+1)-VECTOR S =(TRANSPOSE +C OF (0,...,0,1)). +C +C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF +C DWNNLS( ). + IS(1) = 0 + IS(2) = 0 + CALL DWNNLS(WS,N2+1,0,N2+1,M,0,PRGOPT,WS(IX),RNORM,MODEW, + * IS,WS(IW+1)) +C +C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z. + SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) + IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) + * GO TO 160 + SC = ONE/SC + DO 150 J = 1, N2 + L = N1 + J + X(L) = SC*DDOT(M,A(1,L),1,WS(IX),1)*X(L) + 150 CONTINUE + GO TO 170 + 160 CONTINUE + MODE = 2 +C .........EXIT + GO TO 190 + 170 CONTINUE + 180 CONTINUE +C +C ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION. + CALL DSCAL(N,YNORM,X,1) + WNORM = DNRM2(N1,X,1) + 190 CONTINUE + 200 CONTINUE + RETURN + END +*DECK DWNNLS + SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, + + IWORK, WORK) +C***BEGIN PROLOGUE DWNNLS +C***PURPOSE Solve a linearly constrained least squares problem with +C equality constraints and nonnegativity constraints on +C selected variables. +C***LIBRARY SLATEC +C***CATEGORY K1A2A +C***TYPE DOUBLE PRECISION (WNNLS-S, DWNNLS-D) +C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, +C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, +C NONNEGATIVITY CONSTRAINTS, QUADRATIC PROGRAMMING +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C Abstract +C +C This subprogram solves a linearly constrained least squares +C problem. Suppose there are given matrices E and A of +C respective dimensions ME by N and MA by N, and vectors F +C and B of respective lengths ME and MA. This subroutine +C solves the problem +C +C EX = F, (equations to be exactly satisfied) +C +C AX = B, (equations to be approximately satisfied, +C in the least squares sense) +C +C subject to components L+1,...,N nonnegative +C +C Any values ME.GE.0, MA.GE.0 and 0.LE. L .LE.N are permitted. +C +C The problem is reposed as problem DWNNLS +C +C (WT*E)X = (WT*F) +C ( A) ( B), (least squares) +C subject to components L+1,...,N nonnegative. +C +C The subprogram chooses the heavy weight (or penalty parameter) WT. +C +C The parameters for DWNNLS are +C +C INPUT.. All TYPE REAL variables are DOUBLE PRECISION +C +C W(*,*),MDW, The array W(*,*) is double subscripted with first +C ME,MA,N,L dimensioning parameter equal to MDW. For this +C discussion let us call M = ME + MA. Then MDW +C must satisfy MDW.GE.M. The condition MDW.LT.M +C is an error. +C +C The array W(*,*) contains the matrices and vectors +C +C (E F) +C (A B) +C +C in rows and columns 1,...,M and 1,...,N+1 +C respectively. Columns 1,...,L correspond to +C unconstrained variables X(1),...,X(L). The +C remaining variables are constrained to be +C nonnegative. The condition L.LT.0 or L.GT.N is +C an error. +C +C PRGOPT(*) This double precision array is the option vector. +C If the user is satisfied with the nominal +C subprogram features set +C +C PRGOPT(1)=1 (or PRGOPT(1)=1.0) +C +C Otherwise PRGOPT(*) is a linked list consisting of +C groups of data of the following form +C +C LINK +C KEY +C DATA SET +C +C The parameters LINK and KEY are each one word. +C The DATA SET can be comprised of several words. +C The number of items depends on the value of KEY. +C The value of LINK points to the first +C entry of the next group of data within +C PRGOPT(*). The exception is when there are +C no more options to change. In that +C case LINK=1 and the values KEY and DATA SET +C are not referenced. The general layout of +C PRGOPT(*) is as follows. +C +C ...PRGOPT(1)=LINK1 (link to first entry of next group) +C . PRGOPT(2)=KEY1 (key to the option change) +C . PRGOPT(3)=DATA VALUE (data value for this change) +C . . +C . . +C . . +C ...PRGOPT(LINK1)=LINK2 (link to the first entry of +C . next group) +C . PRGOPT(LINK1+1)=KEY2 (key to the option change) +C . PRGOPT(LINK1+2)=DATA VALUE +C ... . +C . . +C . . +C ...PRGOPT(LINK)=1 (no more options to change) +C +C Values of LINK that are nonpositive are errors. +C A value of LINK.GT.NLINK=100000 is also an error. +C This helps prevent using invalid but positive +C values of LINK that will probably extend +C beyond the program limits of PRGOPT(*). +C Unrecognized values of KEY are ignored. The +C order of the options is arbitrary and any number +C of options can be changed with the following +C restriction. To prevent cycling in the +C processing of the option array a count of the +C number of options changed is maintained. +C Whenever this count exceeds NOPT=1000 an error +C message is printed and the subprogram returns. +C +C OPTIONS.. +C +C KEY=6 +C Scale the nonzero columns of the +C entire data matrix +C (E) +C (A) +C to have length one. The DATA SET for +C this option is a single value. It must +C be nonzero if unit length column scaling is +C desired. +C +C KEY=7 +C Scale columns of the entire data matrix +C (E) +C (A) +C with a user-provided diagonal matrix. +C The DATA SET for this option consists +C of the N diagonal scaling factors, one for +C each matrix column. +C +C KEY=8 +C Change the rank determination tolerance from +C the nominal value of SQRT(SRELPR). This quantity +C can be no smaller than SRELPR, The arithmetic- +C storage precision. The quantity used +C here is internally restricted to be at +C least SRELPR. The DATA SET for this option +C is the new tolerance. +C +C KEY=9 +C Change the blow-up parameter from the +C nominal value of SQRT(SRELPR). The reciprocal of +C this parameter is used in rejecting solution +C components as too large when a variable is +C first brought into the active set. Too large +C means that the proposed component times the +C reciprocal of the parameter is not less than +C the ratio of the norms of the right-side +C vector and the data matrix. +C This parameter can be no smaller than SRELPR, +C the arithmetic-storage precision. +C +C For example, suppose we want to provide +C a diagonal matrix to scale the problem +C matrix and change the tolerance used for +C determining linear dependence of dropped col +C vectors. For these options the dimensions of +C PRGOPT(*) must be at least N+6. The FORTRAN +C statements defining these options would +C be as follows. +C +C PRGOPT(1)=N+3 (link to entry N+3 in PRGOPT(*)) +C PRGOPT(2)=7 (user-provided scaling key) +C +C CALL DCOPY(N,D,1,PRGOPT(3),1) (copy the N +C scaling factors from a user array called D(*) +C into PRGOPT(3)-PRGOPT(N+2)) +C +C PRGOPT(N+3)=N+6 (link to entry N+6 of PRGOPT(*)) +C PRGOPT(N+4)=8 (linear dependence tolerance key) +C PRGOPT(N+5)=... (new value of the tolerance) +C +C PRGOPT(N+6)=1 (no more options to change) +C +C +C IWORK(1), The amounts of working storage actually allocated +C IWORK(2) for the working arrays WORK(*) and IWORK(*), +C respectively. These quantities are compared with +C the actual amounts of storage needed for DWNNLS( ). +C Insufficient storage allocated for either WORK(*) +C or IWORK(*) is considered an error. This feature +C was included in DWNNLS( ) because miscalculating +C the storage formulas for WORK(*) and IWORK(*) +C might very well lead to subtle and hard-to-find +C execution errors. +C +C The length of WORK(*) must be at least +C +C LW = ME+MA+5*N +C This test will not be made if IWORK(1).LE.0. +C +C The length of IWORK(*) must be at least +C +C LIW = ME+MA+N +C This test will not be made if IWORK(2).LE.0. +C +C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION +C +C X(*) An array dimensioned at least N, which will +C contain the N components of the solution vector +C on output. +C +C RNORM The residual norm of the solution. The value of +C RNORM contains the residual vector length of the +C equality constraints and least squares equations. +C +C MODE The value of MODE indicates the success or failure +C of the subprogram. +C +C MODE = 0 Subprogram completed successfully. +C +C = 1 Max. number of iterations (equal to +C 3*(N-L)) exceeded. Nearly all problems +C should complete in fewer than this +C number of iterations. An approximate +C solution and its corresponding residual +C vector length are in X(*) and RNORM. +C +C = 2 Usage error occurred. The offending +C condition is noted with the error +C processing subprogram, XERMSG( ). +C +C User-designated +C Working arrays.. +C +C WORK(*) A double precision working array of length at least +C M + 5*N. +C +C IWORK(*) An integer-valued working array of length at least +C M+N. +C +C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for +C linear least squares problems with equality and +C nonnegativity constraints, Report SAND77-0552, Sandia +C Laboratories, June 1978. +C K. H. Haskell and R. J. Hanson, Selected algorithms for +C the linearly constrained least squares problem - a +C users guide, Report SAND78-1290, Sandia Laboratories, +C August 1979. +C K. H. Haskell and R. J. Hanson, An algorithm for +C linear least squares problems with equality and +C nonnegativity constraints, Mathematical Programming +C 21 (1981), pp. 98-118. +C R. J. Hanson and K. H. Haskell, Two algorithms for the +C linearly constrained least squares problem, ACM +C Transactions on Mathematical Software, September 1982. +C C. L. Lawson and R. J. Hanson, Solving Least Squares +C Problems, Prentice-Hall, Inc., 1974. +C***ROUTINES CALLED DWNLSM, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and revised. (WRB & RWC) +C 891006 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900510 Convert XERRWV calls to XERMSG calls, change Prologue +C comments to agree with WNNLS. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C 180613 Removed prints and replaced DP --> DOUBLE PRECISION. (THC) +C***END PROLOGUE DWNNLS + + INTEGER IWORK(*), L, L1, L2, L3, L4, L5, LIW, LW, MA, MDW, ME, + * MODE, N + DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) +C CHARACTER*8 XERN1 +C***FIRST EXECUTABLE STATEMENT DWNNLS + MODE = 0 + IF (MA+ME.LE.0 .OR. N.LE.0) RETURN +C + IF (IWORK(1).GT.0) THEN + LW = ME + MA + 5*N + IF (IWORK(1).LT.LW) THEN +C WRITE (XERN1, '(I8)') LW +C CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // +C * 'ALLOCATED FOR WORK(*), NEED LW = ' // XERN1, 2, 1) + MODE = 2 + RETURN + ENDIF + ENDIF +C + IF (IWORK(2).GT.0) THEN + LIW = ME + MA + N + IF (IWORK(2).LT.LIW) THEN +C WRITE (XERN1, '(I8)') LIW +C CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // +C * 'ALLOCATED FOR IWORK(*), NEED LIW = ' // XERN1, 2, 1) + MODE = 2 + RETURN + ENDIF + ENDIF +C + IF (MDW.LT.ME+MA) THEN +C CALL XERMSG ('SLATEC', 'DWNNLS', +C * 'THE VALUE MDW.LT.ME+MA IS AN ERROR', 1, 1) + MODE = 2 + RETURN + ENDIF +C + IF (L.LT.0 .OR. L.GT.N) THEN +C CALL XERMSG ('SLATEC', 'DWNNLS', +C * 'L.GE.0 .AND. L.LE.N IS REQUIRED', 2, 1) + MODE = 2 + RETURN + ENDIF +C +C THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS +C WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS +C REQUIRED BY THE MAIN SUBROUTINE DWNLSM( ). +C + L1 = N + 1 + L2 = L1 + N + L3 = L2 + ME + MA + L4 = L3 + N + L5 = L4 + N +C + CALL DWNLSM(W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, IWORK, + * IWORK(L1), WORK(1), WORK(L1), WORK(L2), WORK(L3), + * WORK(L4), WORK(L5)) + RETURN + END +*DECK DWNLSM + SUBROUTINE DWNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, + + IPIVOT, ITYPE, WD, H, SCALE, Z, TEMP, D) +C***BEGIN PROLOGUE DWNLSM +C***SUBSIDIARY +C***PURPOSE Subsidiary to DWNNLS +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (WNLSM-S, DWNLSM-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C This is a companion subprogram to DWNNLS. +C The documentation for DWNNLS has complete usage instructions. +C +C In addition to the parameters discussed in the prologue to +C subroutine DWNNLS, the following work arrays are used in +C subroutine DWNLSM (they are passed through the calling +C sequence from DWNNLS for purposes of variable dimensioning). +C Their contents will in general be of no interest to the user. +C +C Variables of type REAL are DOUBLE PRECISION. +C +C IPIVOT(*) +C An array of length N. Upon completion it contains the +C pivoting information for the cols of W(*,*). +C +C ITYPE(*) +C An array of length M which is used to keep track +C of the classification of the equations. ITYPE(I)=0 +C denotes equation I as an equality constraint. +C ITYPE(I)=1 denotes equation I as a least squares +C equation. +C +C WD(*) +C An array of length N. Upon completion it contains the +C dual solution vector. +C +C H(*) +C An array of length N. Upon completion it contains the +C pivot scalars of the Householder transformations performed +C in the case KRANK.LT.L. +C +C SCALE(*) +C An array of length M which is used by the subroutine +C to store the diagonal matrix of weights. +C These are used to apply the modified Givens +C transformations. +C +C Z(*),TEMP(*) +C Working arrays of length N. +C +C D(*) +C An array of length N that contains the +C column scaling for the matrix (E). +C (A) +C +C***SEE ALSO DWNNLS +C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, +C SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, +C DWNLIT, IDAMAX, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and revised. (WRB & RWC) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900328 Added TYPE section. (WRB) +C 900510 Fixed an error message. (RWC) +C 900604 DP version created from SP version. (RWC) +C 900911 Restriction on value of ALAMDA included. (WRB) +C***END PROLOGUE DWNLSM + + INTEGER IPIVOT(*), ITYPE(*), L, MA, MDW, MME, MODE, N + DOUBLE PRECISION D(*), H(*), PRGOPT(*), RNORM, SCALE(*), TEMP(*), + * W(MDW,*), WD(*), X(*), Z(*) +C + EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, SLATEC_DROTM, + * SLATEC_DROTMG, DSCAL, DSWAP, DWNLIT, IDAMAX, XERMSG + DOUBLE PRECISION D1MACH, DASUM, DNRM2 + INTEGER IDAMAX +C + DOUBLE PRECISION ALAMDA, ALPHA, ALSQ, AMAX, BLOWUP, BNORM, + * DOPE(3), DRELPR, EANORM, FAC, SM, SPARAM(5), T, TAU, WMAX, Z2, + * ZZ + INTEGER I, IDOPE(3), IMAX, ISOL, ITEMP, ITER, ITMAX, IWMAX, J, + * JCON, JP, KEY, KRANK, L1, LAST, LINK, M, ME, NEXT, NIV, NLINK, + * NOPT, NSOLN, NTIMES + LOGICAL DONE, FEASBL, FIRST, HITCON, POS +C + SAVE DRELPR, FIRST + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DWNLSM +C +C Initialize variables. +C DRELPR is the precision for the particular machine +C being used. This logic avoids resetting it every entry. +C + IF (FIRST) DRELPR = D1MACH(4) + FIRST = .FALSE. +C +C Set the nominal tolerance used in the code. +C + TAU = SQRT(DRELPR) +C + M = MA + MME + ME = MME + MODE = 2 +C +C To process option vector +C + FAC = 1.D-4 +C +C Set the nominal blow up factor used in the code. +C + BLOWUP = TAU +C +C The nominal column scaling used in the code is +C the identity scaling. +C + CALL DCOPY (N, 1.D0, 0, D, 1) +C +C Define bound for number of options to change. +C + NOPT = 1000 +C +C Define bound for positive value of LINK. +C + NLINK = 100000 + NTIMES = 0 + LAST = 1 + LINK = PRGOPT(1) + IF (LINK.LE.0 .OR. LINK.GT.NLINK) THEN +C CALL XERMSG ('SLATEC', 'DWNLSM', +C + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) + RETURN + ENDIF +C + 100 IF (LINK.GT.1) THEN + NTIMES = NTIMES + 1 + IF (NTIMES.GT.NOPT) THEN +C CALL XERMSG ('SLATEC', 'DWNLSM', +C + 'IN DWNNLS, THE LINKS IN THE OPTION VECTOR ARE CYCLING.', +C + 3, 1) + RETURN + ENDIF +C + KEY = PRGOPT(LAST+1) + IF (KEY.EQ.6 .AND. PRGOPT(LAST+2).NE.0.D0) THEN + DO 110 J = 1,N + T = DNRM2(M,W(1,J),1) + IF (T.NE.0.D0) T = 1.D0/T + D(J) = T + 110 CONTINUE + ENDIF +C + IF (KEY.EQ.7) CALL DCOPY (N, PRGOPT(LAST+2), 1, D, 1) + IF (KEY.EQ.8) TAU = MAX(DRELPR,PRGOPT(LAST+2)) + IF (KEY.EQ.9) BLOWUP = MAX(DRELPR,PRGOPT(LAST+2)) +C + NEXT = PRGOPT(LINK) + IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN +C CALL XERMSG ('SLATEC', 'DWNLSM', +C + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) + RETURN + ENDIF +C + LAST = LINK + LINK = NEXT + GO TO 100 + ENDIF +C + DO 120 J = 1,N + CALL DSCAL (M, D(J), W(1,J), 1) + 120 CONTINUE +C +C Process option vector +C + DONE = .FALSE. + ITER = 0 + ITMAX = 3*(N-L) + MODE = 0 + NSOLN = L + L1 = MIN(M,L) +C +C Compute scale factor to apply to equality constraint equations. +C + DO 130 J = 1,N + WD(J) = DASUM(M,W(1,J),1) + 130 CONTINUE +C + IMAX = IDAMAX(N,WD,1) + EANORM = WD(IMAX) + BNORM = DASUM(M,W(1,N+1),1) + ALAMDA = EANORM/(DRELPR*FAC) +C +C On machines, such as the VAXes using D floating, with a very +C limited exponent range for double precision values, the previously +C computed value of ALAMDA may cause an overflow condition. +C Therefore, this code further limits the value of ALAMDA. +C + ALAMDA = MIN(ALAMDA,SQRT(D1MACH(2))) +C +C Define scaling diagonal matrix for modified Givens usage and +C classify equation types. +C + ALSQ = ALAMDA**2 + DO 140 I = 1,M +C +C When equation I is heavily weighted ITYPE(I)=0, +C else ITYPE(I)=1. +C + IF (I.LE.ME) THEN + T = ALSQ + ITEMP = 0 + ELSE + T = 1.D0 + ITEMP = 1 + ENDIF + SCALE(I) = T + ITYPE(I) = ITEMP + 140 CONTINUE +C +C Set the solution vector X(*) to zero and the column interchange +C matrix to the identity. +C + CALL DCOPY (N, 0.D0, 0, X, 1) + DO 150 I = 1,N + IPIVOT(I) = I + 150 CONTINUE +C +C Perform initial triangularization in the submatrix +C corresponding to the unconstrained variables. +C Set first L components of dual vector to zero because +C these correspond to the unconstrained variables. +C + CALL DCOPY (L, 0.D0, 0, WD, 1) +C +C The arrays IDOPE(*) and DOPE(*) are used to pass +C information to DWNLIT(). This was done to avoid +C a long calling sequence or the use of COMMON. +C + IDOPE(1) = ME + IDOPE(2) = NSOLN + IDOPE(3) = L1 +C + DOPE(1) = ALSQ + DOPE(2) = EANORM + DOPE(3) = TAU + CALL DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM, + + IDOPE, DOPE, DONE) + ME = IDOPE(1) + KRANK = IDOPE(2) + NIV = IDOPE(3) +C +C Perform WNNLS algorithm using the following steps. +C +C Until(DONE) +C compute search direction and feasible point +C when (HITCON) add constraints +C else perform multiplier test and drop a constraint +C fin +C Compute-Final-Solution +C +C To compute search direction and feasible point, +C solve the triangular system of currently non-active +C variables and store the solution in Z(*). +C +C To solve system +C Copy right hand side into TEMP vector to use overwriting method. +C + 160 IF (DONE) GO TO 330 + ISOL = L + 1 + IF (NSOLN.GE.ISOL) THEN + CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) + DO 170 J = NSOLN,ISOL,-1 + IF (J.GT.KRANK) THEN + I = NIV - NSOLN + J + ELSE + I = J + ENDIF +C + IF (J.GT.KRANK .AND. J.LE.L) THEN + Z(J) = 0.D0 + ELSE + Z(J) = TEMP(I)/W(I,J) + CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) + ENDIF + 170 CONTINUE + ENDIF +C +C Increment iteration counter and check against maximum number +C of iterations. +C + ITER = ITER + 1 + IF (ITER.GT.ITMAX) THEN + MODE = 1 + DONE = .TRUE. + ENDIF +C +C Check to see if any constraints have become active. +C If so, calculate an interpolation factor so that all +C active constraints are removed from the basis. +C + ALPHA = 2.D0 + HITCON = .FALSE. + DO 180 J = L+1,NSOLN + ZZ = Z(J) + IF (ZZ.LE.0.D0) THEN + T = X(J)/(X(J)-ZZ) + IF (T.LT.ALPHA) THEN + ALPHA = T + JCON = J + ENDIF + HITCON = .TRUE. + ENDIF + 180 CONTINUE +C +C Compute search direction and feasible point +C + IF (HITCON) THEN +C +C To add constraints, use computed ALPHA to interpolate between +C last feasible solution X(*) and current unconstrained (and +C infeasible) solution Z(*). +C + DO 190 J = L+1,NSOLN + X(J) = X(J) + ALPHA*(Z(J)-X(J)) + 190 CONTINUE + FEASBL = .FALSE. +C +C Remove column JCON and shift columns JCON+1 through N to the +C left. Swap column JCON into the N th position. This achieves +C upper Hessenberg form for the nonactive constraints and +C leaves an upper Hessenberg matrix to retriangularize. +C + 200 DO 210 I = 1,M + T = W(I,JCON) + CALL DCOPY (N-JCON, W(I, JCON+1), MDW, W(I, JCON), MDW) + W(I,N) = T + 210 CONTINUE +C +C Update permuted index vector to reflect this shift and swap. +C + ITEMP = IPIVOT(JCON) + DO 220 I = JCON,N - 1 + IPIVOT(I) = IPIVOT(I+1) + 220 CONTINUE + IPIVOT(N) = ITEMP +C +C Similarly permute X(*) vector. +C + CALL DCOPY (N-JCON, X(JCON+1), 1, X(JCON), 1) + X(N) = 0.D0 + NSOLN = NSOLN - 1 + NIV = NIV - 1 +C +C Retriangularize upper Hessenberg matrix after adding +C constraints. +C + I = KRANK + JCON - L + DO 230 J = JCON,NSOLN + IF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.0) THEN +C +C Zero IP1 to I in column J +C + IF (W(I+1,J).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), + + W(I+1,J), SPARAM) + W(I+1,J) = 0.D0 + CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), + + MDW, SPARAM) + ENDIF + ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.1) THEN +C +C Zero IP1 to I in column J +C + IF (W(I+1,J).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), + + W(I+1,J), SPARAM) + W(I+1,J) = 0.D0 + CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), + + MDW, SPARAM) + ENDIF + ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.0) THEN + CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) + CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) + ITEMP = ITYPE(I+1) + ITYPE(I+1) = ITYPE(I) + ITYPE(I) = ITEMP +C +C Swapped row was formerly a pivot element, so it will +C be large enough to perform elimination. +C Zero IP1 to I in column J. +C + IF (W(I+1,J).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), + + W(I+1,J), SPARAM) + W(I+1,J) = 0.D0 + CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), + + MDW, SPARAM) + ENDIF + ELSEIF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.1) THEN + IF (SCALE(I)*W(I,J)**2/ALSQ.GT.(TAU*EANORM)**2) THEN +C +C Zero IP1 to I in column J +C + IF (W(I+1,J).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), + + W(I+1,J), SPARAM) + W(I+1,J) = 0.D0 + CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, + + W(I+1,J+1), MDW, SPARAM) + ENDIF + ELSE + CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) + CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) + ITEMP = ITYPE(I+1) + ITYPE(I+1) = ITYPE(I) + ITYPE(I) = ITEMP + W(I+1,J) = 0.D0 + ENDIF + ENDIF + I = I + 1 + 230 CONTINUE +C +C See if the remaining coefficients in the solution set are +C feasible. They should be because of the way ALPHA was +C determined. If any are infeasible, it is due to roundoff +C error. Any that are non-positive will be set to zero and +C removed from the solution set. +C + DO 240 JCON = L+1,NSOLN + IF (X(JCON).LE.0.D0) GO TO 250 + 240 CONTINUE + FEASBL = .TRUE. + 250 IF (.NOT.FEASBL) GO TO 200 + ELSE +C +C To perform multiplier test and drop a constraint. +C + CALL DCOPY (NSOLN, Z, 1, X, 1) + IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) +C +C Reclassify least squares equations as equalities as necessary. +C + I = NIV + 1 + 260 IF (I.LE.ME) THEN + IF (ITYPE(I).EQ.0) THEN + I = I + 1 + ELSE + CALL DSWAP (N+1, W(I,1), MDW, W(ME,1), MDW) + CALL DSWAP (1, SCALE(I), 1, SCALE(ME), 1) + ITEMP = ITYPE(I) + ITYPE(I) = ITYPE(ME) + ITYPE(ME) = ITEMP + ME = ME - 1 + ENDIF + GO TO 260 + ENDIF +C +C Form inner product vector WD(*) of dual coefficients. +C + DO 280 J = NSOLN+1,N + SM = 0.D0 + DO 270 I = NSOLN+1,M + SM = SM + SCALE(I)*W(I,J)*W(I,N+1) + 270 CONTINUE + WD(J) = SM + 280 CONTINUE +C +C Find J such that WD(J)=WMAX is maximum. This determines +C that the incoming column J will reduce the residual vector +C and be positive. +C + 290 WMAX = 0.D0 + IWMAX = NSOLN + 1 + DO 300 J = NSOLN+1,N + IF (WD(J).GT.WMAX) THEN + WMAX = WD(J) + IWMAX = J + ENDIF + 300 CONTINUE + IF (WMAX.LE.0.D0) GO TO 330 +C +C Set dual coefficients to zero for incoming column. +C + WD(IWMAX) = 0.D0 +C +C WMAX .GT. 0.D0, so okay to move column IWMAX to solution set. +C Perform transformation to retriangularize, and test for near +C linear dependence. +C +C Swap column IWMAX into NSOLN-th position to maintain upper +C Hessenberg form of adjacent columns, and add new column to +C triangular decomposition. +C + NSOLN = NSOLN + 1 + NIV = NIV + 1 + IF (NSOLN.NE.IWMAX) THEN + CALL DSWAP (M, W(1,NSOLN), 1, W(1,IWMAX), 1) + WD(IWMAX) = WD(NSOLN) + WD(NSOLN) = 0.D0 + ITEMP = IPIVOT(NSOLN) + IPIVOT(NSOLN) = IPIVOT(IWMAX) + IPIVOT(IWMAX) = ITEMP + ENDIF +C +C Reduce column NSOLN so that the matrix of nonactive constraints +C variables is triangular. +C + DO 320 J = M,NIV+1,-1 + JP = J - 1 +C +C When operating near the ME line, test to see if the pivot +C element is near zero. If so, use the largest element above +C it as the pivot. This is to maintain the sharp interface +C between weighted and non-weighted rows in all cases. +C + IF (J.EQ.ME+1) THEN + IMAX = ME + AMAX = SCALE(ME)*W(ME,NSOLN)**2 + DO 310 JP = J - 1,NIV,-1 + T = SCALE(JP)*W(JP,NSOLN)**2 + IF (T.GT.AMAX) THEN + IMAX = JP + AMAX = T + ENDIF + 310 CONTINUE + JP = IMAX + ENDIF +C + IF (W(J,NSOLN).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(JP), SCALE(J), W(JP,NSOLN), + + W(J,NSOLN), SPARAM) + W(J,NSOLN) = 0.D0 + CALL SLATEC_DROTM (N+1-NSOLN, W(JP,NSOLN+1), MDW, + + W(J,NSOLN+1), MDW, SPARAM) + ENDIF + 320 CONTINUE +C +C Solve for Z(NSOLN)=proposed new value for X(NSOLN). Test if +C this is nonpositive or too large. If this was true or if the +C pivot term was zero, reject the column as dependent. +C + IF (W(NIV,NSOLN).NE.0.D0) THEN + ISOL = NIV + Z2 = W(ISOL,N+1)/W(ISOL,NSOLN) + Z(NSOLN) = Z2 + POS = Z2 .GT. 0.D0 + IF (Z2*EANORM.GE.BNORM .AND. POS) THEN + POS = .NOT. (BLOWUP*Z2*EANORM.GE.BNORM) + ENDIF +C +C Try to add row ME+1 as an additional equality constraint. +C Check size of proposed new solution component. +C Reject it if it is too large. +C + ELSEIF (NIV.LE.ME .AND. W(ME+1,NSOLN).NE.0.D0) THEN + ISOL = ME + 1 + IF (POS) THEN +C +C Swap rows ME+1 and NIV, and scale factors for these rows. +C + CALL DSWAP (N+1, W(ME+1,1), MDW, W(NIV,1), MDW) + CALL DSWAP (1, SCALE(ME+1), 1, SCALE(NIV), 1) + ITEMP = ITYPE(ME+1) + ITYPE(ME+1) = ITYPE(NIV) + ITYPE(NIV) = ITEMP + ME = ME + 1 + ENDIF + ELSE + POS = .FALSE. + ENDIF +C + IF (.NOT.POS) THEN + NSOLN = NSOLN - 1 + NIV = NIV - 1 + ENDIF + IF (.NOT.(POS.OR.DONE)) GO TO 290 + ENDIF + GO TO 160 +C +C Else perform multiplier test and drop a constraint. To compute +C final solution. Solve system, store results in X(*). +C +C Copy right hand side into TEMP vector to use overwriting method. +C + 330 ISOL = 1 + IF (NSOLN.GE.ISOL) THEN + CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) + DO 340 J = NSOLN,ISOL,-1 + IF (J.GT.KRANK) THEN + I = NIV - NSOLN + J + ELSE + I = J + ENDIF +C + IF (J.GT.KRANK .AND. J.LE.L) THEN + Z(J) = 0.D0 + ELSE + Z(J) = TEMP(I)/W(I,J) + CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) + ENDIF + 340 CONTINUE + ENDIF +C +C Solve system. +C + CALL DCOPY (NSOLN, Z, 1, X, 1) +C +C Apply Householder transformations to X(*) if KRANK.LT.L +C + IF (KRANK.LT.L) THEN + DO 350 I = 1,KRANK + CALL DH12 (2, I, KRANK+1, L, W(I,1), MDW, H(I), X, 1, 1, 1) + 350 CONTINUE + ENDIF +C +C Fill in trailing zeroes for constrained variables not in solution. +C + IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) +C +C Permute solution vector to natural order. +C + DO 380 I = 1,N + J = I + 360 IF (IPIVOT(J).EQ.I) GO TO 370 + J = J + 1 + GO TO 360 +C + 370 IPIVOT(J) = IPIVOT(I) + IPIVOT(I) = J + CALL DSWAP (1, X(J), 1, X(I), 1) + 380 CONTINUE +C +C Rescale the solution using the column scaling. +C + DO 390 J = 1,N + X(J) = X(J)*D(J) + 390 CONTINUE +C + DO 400 I = NSOLN+1,M + T = W(I,N+1) + IF (I.LE.ME) T = T/ALAMDA + T = (SCALE(I)*T)*T + RNORM = RNORM + T + 400 CONTINUE +C + RNORM = SQRT(RNORM) + RETURN + END +*DECK DROTM + SUBROUTINE SLATEC_DROTM (N, DX, INCX, DY, INCY, DPARAM) +C***BEGIN PROLOGUE SLATEC_DROTM +C***PURPOSE Apply a modified Givens transformation. +C***LIBRARY SLATEC (BLAS) +C***CATEGORY D1A8 +C***TYPE DOUBLE PRECISION (SROTM-S, DROTM-D) +C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***DESCRIPTION +C +C B L A S Subprogram +C Description of Parameters +C +C --Input-- +C N number of elements in input vector(s) +C DX double precision vector with N elements +C INCX storage spacing between elements of DX +C DY double precision vector with N elements +C INCY storage spacing between elements of DY +C DPARAM 5-element D.P. vector. DPARAM(1) is DFLAG described below. +C Locations 2-5 of SPARAM contain elements of the +C transformation matrix H described below. +C +C --Output-- +C DX rotated vector (unchanged if N .LE. 0) +C DY rotated vector (unchanged if N .LE. 0) +C +C Apply the modified Givens transformation, H, to the 2 by N matrix +C (DX**T) +C (DY**T) , where **T indicates transpose. The elements of DX are +C in DX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else +C LX = 1+(1-N)*INCX, and similarly for DY using LY and INCY. +C +C With DPARAM(1)=DFLAG, H has one of the following forms: +C +C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 +C +C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) +C H=( ) ( ) ( ) ( ) +C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). +C +C See SLATEC_DROTMG for a description of data storage in DPARAM. +C +C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +C Krogh, Basic linear algebra subprograms for Fortran +C usage, Algorithm No. 539, Transactions on Mathematical +C Software 5, 3 (September 1979), pp. 308-323. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 791001 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920310 Corrected definition of LX in DESCRIPTION. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 180613 Renamed SLATEC_DROTM to avoid BLAS naming conflict. (THC) +C***END PROLOGUE SLATEC_DROTM + + DOUBLE PRECISION DFLAG, DH12, DH22, DX, TWO, Z, DH11, DH21, + 1 DPARAM, DY, W, ZERO + DIMENSION DX(*), DY(*), DPARAM(5) + SAVE ZERO, TWO + DATA ZERO, TWO /0.0D0, 2.0D0/ +C***FIRST EXECUTABLE STATEMENT SLATEC_DROTM + DFLAG=DPARAM(1) + IF (N.LE.0 .OR. (DFLAG+TWO.EQ.ZERO)) GO TO 140 + IF (.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 +C + NSTEPS=N*INCX +C IF (DFLAG) 50, 10, 30 +C Replaced obsolete code above with an IF-block (THC). + IF (DFLAG < 0) THEN + GO TO 50 + ELSE IF (DFLAG == 0) THEN + GO TO 10 + ELSE IF (DFLAG > 0) THEN + GO TO 30 + END IF + 10 CONTINUE + DH12=DPARAM(4) + DH21=DPARAM(3) + DO 20 I = 1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=W+Z*DH12 + DY(I)=W*DH21+Z + 20 CONTINUE + GO TO 140 + 30 CONTINUE + DH11=DPARAM(2) + DH22=DPARAM(5) + DO 40 I = 1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=W*DH11+Z + DY(I)=-W+DH22*Z + 40 CONTINUE + GO TO 140 + 50 CONTINUE + DH11=DPARAM(2) + DH12=DPARAM(4) + DH21=DPARAM(3) + DH22=DPARAM(5) + DO 60 I = 1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=W*DH11+Z*DH12 + DY(I)=W*DH21+Z*DH22 + 60 CONTINUE + GO TO 140 + 70 CONTINUE + KX=1 + KY=1 + IF (INCX .LT. 0) KX = 1+(1-N)*INCX + IF (INCY .LT. 0) KY = 1+(1-N)*INCY +C +C IF (DFLAG) 120,80,100 +C Replaced obsolete code above with an IF-block (THC). + IF (DFLAG < 0) THEN + GO TO 120 + ELSE IF (DFLAG == 0) THEN + GO TO 80 + ELSE IF (DFLAG > 0) THEN + GO TO 100 + END IF + 80 CONTINUE + DH12=DPARAM(4) + DH21=DPARAM(3) + DO 90 I = 1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=W+Z*DH12 + DY(KY)=W*DH21+Z + KX=KX+INCX + KY=KY+INCY + 90 CONTINUE + GO TO 140 + 100 CONTINUE + DH11=DPARAM(2) + DH22=DPARAM(5) + DO 110 I = 1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=W*DH11+Z + DY(KY)=-W+DH22*Z + KX=KX+INCX + KY=KY+INCY + 110 CONTINUE + GO TO 140 + 120 CONTINUE + DH11=DPARAM(2) + DH12=DPARAM(4) + DH21=DPARAM(3) + DH22=DPARAM(5) + DO 130 I = 1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=W*DH11+Z*DH12 + DY(KY)=W*DH21+Z*DH22 + KX=KX+INCX + KY=KY+INCY + 130 CONTINUE + 140 CONTINUE + RETURN + END +*DECK SLATEC_DROTMG + SUBROUTINE SLATEC_DROTMG (DD1, DD2, DX1, DY1, DPARAM) +C***BEGIN PROLOGUE SLATEC_DROTMG +C***PURPOSE Construct a modified Givens transformation. +C***LIBRARY SLATEC (BLAS) +C***CATEGORY D1B10 +C***TYPE DOUBLE PRECISION (SROTMG-S, DROTMG-D) +C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***DESCRIPTION +C +C B L A S Subprogram +C Description of Parameters +C +C --Input-- +C DD1 double precision scalar +C DD2 double precision scalar +C DX1 double precision scalar +C DX2 double precision scalar +C DPARAM D.P. 5-vector. DPARAM(1)=DFLAG defined below. +C Locations 2-5 contain the rotation matrix. +C +C --Output-- +C DD1 changed to represent the effect of the transformation +C DD2 changed to represent the effect of the transformation +C DX1 changed to represent the effect of the transformation +C DX2 unchanged +C +C Construct the modified Givens transformation matrix H which zeros +C the second component of the 2-vector (SQRT(DD1)*DX1,SQRT(DD2)* +C DY2)**T. +C With DPARAM(1)=DFLAG, H has one of the following forms: +C +C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 +C +C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) +C H=( ) ( ) ( ) ( ) +C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). +C +C Locations 2-5 of DPARAM contain DH11, DH21, DH12, and DH22, +C respectively. (Values of 1.D0, -1.D0, or 0.D0 implied by the +C value of DPARAM(1) are not stored in DPARAM.) +C +C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +C Krogh, Basic linear algebra subprograms for Fortran +C usage, Algorithm No. 539, Transactions on Mathematical +C Software 5, 3 (September 1979), pp. 308-323. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 780301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920316 Prologue corrected. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 180613 Renamed SLATEC_DROTMG to avoid BLAS naming conflict. (THC) +C***END PROLOGUE SLATEC_DROTMG + + DOUBLE PRECISION GAM, ONE, RGAMSQ, DD1, DD2, DH11, DH12, DH21, + 1 DH22, DPARAM, DP1, DP2, DQ1, DQ2, DU, DY1, ZERO, + 2 GAMSQ, DFLAG, DTEMP, DX1, TWO + DIMENSION DPARAM(5) + SAVE ZERO, ONE, TWO, GAM, GAMSQ, RGAMSQ + DATA ZERO, ONE, TWO /0.0D0, 1.0D0, 2.0D0/ + DATA GAM, GAMSQ, RGAMSQ /4096.0D0, 16777216.D0, 5.9604645D-8/ +C***FIRST EXECUTABLE STATEMENT SLATEC_DROTMG + IF (.NOT. DD1 .LT. ZERO) GO TO 10 +C GO ZERO-H-D-AND-DX1.. + GO TO 60 + 10 CONTINUE +C CASE-DD1-NONNEGATIVE + DP2=DD2*DY1 + IF (.NOT. DP2 .EQ. ZERO) GO TO 20 + DFLAG=-TWO + GO TO 260 +C REGULAR-CASE.. + 20 CONTINUE + DP1=DD1*DX1 + DQ2=DP2*DY1 + DQ1=DP1*DX1 +C + IF (.NOT. ABS(DQ1) .GT. ABS(DQ2)) GO TO 40 + DH21=-DY1/DX1 + DH12=DP2/DP1 +C + DU=ONE-DH12*DH21 +C + IF (.NOT. DU .LE. ZERO) GO TO 30 +C GO ZERO-H-D-AND-DX1.. + GO TO 60 + 30 CONTINUE + DFLAG=ZERO + DD1=DD1/DU + DD2=DD2/DU + DX1=DX1*DU +C GO SCALE-CHECK.. + GO TO 100 + 40 CONTINUE + IF (.NOT. DQ2 .LT. ZERO) GO TO 50 +C GO ZERO-H-D-AND-DX1.. + GO TO 60 + 50 CONTINUE + DFLAG=ONE + DH11=DP1/DP2 + DH22=DX1/DY1 + DU=ONE+DH11*DH22 + DTEMP=DD2/DU + DD2=DD1/DU + DD1=DTEMP + DX1=DY1*DU +C GO SCALE-CHECK + GO TO 100 +C PROCEDURE..ZERO-H-D-AND-DX1.. + 60 CONTINUE + DFLAG=-ONE + DH11=ZERO + DH12=ZERO + DH21=ZERO + DH22=ZERO +C + DD1=ZERO + DD2=ZERO + DX1=ZERO +C RETURN.. + GO TO 220 +C PROCEDURE..FIX-H.. + 70 CONTINUE + IF (.NOT. DFLAG .GE. ZERO) GO TO 90 +C + IF (.NOT. DFLAG .EQ. ZERO) GO TO 80 + DH11=ONE + DH22=ONE + DFLAG=-ONE + GO TO 90 + 80 CONTINUE + DH21=-ONE + DH12=ONE + DFLAG=-ONE + 90 CONTINUE +C GO TO IGO,(120,150,180,210) +C Replaced the above obsolete code with modern alternative (THC). + SELECT CASE(IGO) + CASE(120) + GO TO 120 + CASE(150) + GO TO 150 + CASE(180) + GO TO 180 + CASE(210) + GO TO 210 + END SELECT +C PROCEDURE..SCALE-CHECK + 100 CONTINUE + 110 CONTINUE + IF (.NOT. DD1 .LE. RGAMSQ) GO TO 130 + IF (DD1 .EQ. ZERO) GO TO 160 + IGO = 120 +C FIX-H.. + GO TO 70 + 120 CONTINUE + DD1=DD1*GAM**2 + DX1=DX1/GAM + DH11=DH11/GAM + DH12=DH12/GAM + GO TO 110 + 130 CONTINUE + 140 CONTINUE + IF (.NOT. DD1 .GE. GAMSQ) GO TO 160 + IGO = 150 +C FIX-H.. + GO TO 70 + 150 CONTINUE + DD1=DD1/GAM**2 + DX1=DX1*GAM + DH11=DH11*GAM + DH12=DH12*GAM + GO TO 140 + 160 CONTINUE + 170 CONTINUE + IF (.NOT. ABS(DD2) .LE. RGAMSQ) GO TO 190 + IF (DD2 .EQ. ZERO) GO TO 220 + IGO = 180 +C FIX-H.. + GO TO 70 + 180 CONTINUE + DD2=DD2*GAM**2 + DH21=DH21/GAM + DH22=DH22/GAM + GO TO 170 + 190 CONTINUE + 200 CONTINUE + IF (.NOT. ABS(DD2) .GE. GAMSQ) GO TO 220 + IGO = 210 +C FIX-H.. + GO TO 70 + 210 CONTINUE + DD2=DD2/GAM**2 + DH21=DH21*GAM + DH22=DH22*GAM + GO TO 200 + 220 CONTINUE +C IF (DFLAG) 250,230,240 +C Replaced obsolete code above with an IF-block (THC). + IF (DFLAG < 0) THEN + GO TO 250 + ELSE IF (DFLAG == 0) THEN + GO TO 230 + ELSE IF (DFLAG > 0) THEN + GO TO 240 + END IF + + 230 CONTINUE + DPARAM(3)=DH21 + DPARAM(4)=DH12 + GO TO 260 + 240 CONTINUE + DPARAM(2)=DH11 + DPARAM(5)=DH22 + GO TO 260 + 250 CONTINUE + DPARAM(2)=DH11 + DPARAM(3)=DH21 + DPARAM(4)=DH12 + DPARAM(5)=DH22 + 260 CONTINUE + DPARAM(1)=DFLAG + RETURN + END +*DECK DWNLIT + SUBROUTINE DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, + + RNORM, IDOPE, DOPE, DONE) +C***BEGIN PROLOGUE DWNLIT +C***SUBSIDIARY +C***PURPOSE Subsidiary to DWNNLS +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (WNLIT-S, DWNLIT-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C This is a companion subprogram to DWNNLS( ). +C The documentation for DWNNLS( ) has complete usage instructions. +C +C Note The M by (N+1) matrix W( , ) contains the rt. hand side +C B as the (N+1)st col. +C +C Triangularize L1 by L1 subsystem, where L1=MIN(M,L), with +C col interchanges. +C +C***SEE ALSO DWNNLS +C***ROUTINES CALLED DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, +C DSWAP, DWNLT1, DWNLT2, DWNLT3, IDAMAX +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and revised. (WRB & RWC) +C 890620 Revised to make WNLT1, WNLT2, and WNLT3 subroutines. (RWC) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900604 DP version created from SP version. . (RWC) +C***END PROLOGUE DWNLIT + + INTEGER IDOPE(*), IPIVOT(*), ITYPE(*), L, M, MDW, N + DOUBLE PRECISION DOPE(*), H(*), RNORM, SCALE(*), W(MDW,*) + LOGICAL DONE +C + EXTERNAL DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, + * DWNLT1, DWNLT2, DWNLT3, IDAMAX + INTEGER IDAMAX + LOGICAL DWNLT2 +C + DOUBLE PRECISION ALSQ, AMAX, EANORM, FACTOR, HBAR, RN, SPARAM(5), + * T, TAU + INTEGER I, I1, IMAX, IR, J, J1, JJ, JP, KRANK, L1, LB, LEND, ME, + * MEND, NIV, NSOLN + LOGICAL INDEP, RECALC +C +C***FIRST EXECUTABLE STATEMENT DWNLIT + ME = IDOPE(1) + NSOLN = IDOPE(2) + L1 = IDOPE(3) +C + ALSQ = DOPE(1) + EANORM = DOPE(2) + TAU = DOPE(3) +C + LB = MIN(M-1,L) + RECALC = .TRUE. + RNORM = 0.D0 + KRANK = 0 +C +C We set FACTOR=1.0 so that the heavy weight ALAMDA will be +C included in the test for column independence. +C + FACTOR = 1.D0 + LEND = L + DO 180 I=1,LB +C +C Set IR to point to the I-th row. +C + IR = I + MEND = M + CALL DWNLT1 (I, LEND, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, + + W) +C +C Update column SS and find pivot column. +C + CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) +C +C Perform column interchange. +C Test independence of incoming column. +C + 130 IF (DWNLT2(ME, MEND, IR, FACTOR, TAU, SCALE, W(1,I))) THEN +C +C Eliminate I-th column below diagonal using modified Givens +C transformations applied to (A B). +C +C When operating near the ME line, use the largest element +C above it as the pivot. +C + DO 160 J=M,I+1,-1 + JP = J-1 + IF (J.EQ.ME+1) THEN + IMAX = ME + AMAX = SCALE(ME)*W(ME,I)**2 + DO 150 JP=J-1,I,-1 + T = SCALE(JP)*W(JP,I)**2 + IF (T.GT.AMAX) THEN + IMAX = JP + AMAX = T + ENDIF + 150 CONTINUE + JP = IMAX + ENDIF +C + IF (W(J,I).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(JP), SCALE(J), W(JP,I), + + W(J,I), SPARAM) + W(J,I) = 0.D0 + CALL SLATEC_DROTM (N+1-I, W(JP,I+1), MDW, W(J,I+1), + + MDW, SPARAM) + ENDIF + 160 CONTINUE + ELSE IF (LEND.GT.I) THEN +C +C Column I is dependent. Swap with column LEND. +C Perform column interchange, +C and find column in remaining set with largest SS. +C + CALL DWNLT3 (I, LEND, M, MDW, IPIVOT, H, W) + LEND = LEND - 1 + IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 + HBAR = H(IMAX) + GO TO 130 + ELSE + KRANK = I - 1 + GO TO 190 + ENDIF + 180 CONTINUE + KRANK = L1 +C + 190 IF (KRANK.LT.ME) THEN + FACTOR = ALSQ + DO 200 I=KRANK+1,ME + CALL DCOPY (L, 0.D0, 0, W(I,1), MDW) + 200 CONTINUE +C +C Determine the rank of the remaining equality constraint +C equations by eliminating within the block of constrained +C variables. Remove any redundant constraints. +C + RECALC = .TRUE. + LB = MIN(L+ME-KRANK, N) + DO 270 I=L+1,LB + IR = KRANK + I - L + LEND = N + MEND = ME + CALL DWNLT1 (I, LEND, ME, IR, MDW, RECALC, IMAX, HBAR, H, + + SCALE, W) +C +C Update col ss and find pivot col +C + CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) +C +C Perform column interchange +C Eliminate elements in the I-th col. +C + DO 240 J=ME,IR+1,-1 + IF (W(J,I).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), + + W(J,I), SPARAM) + W(J,I) = 0.D0 + CALL SLATEC_DROTM (N+1-I, W(J-1,I+1), MDW,W(J,I+1), + + MDW, SPARAM) + ENDIF + 240 CONTINUE +C +C I=column being eliminated. +C Test independence of incoming column. +C Remove any redundant or dependent equality constraints. +C + IF (.NOT.DWNLT2(ME, MEND, IR, FACTOR,TAU,SCALE,W(1,I))) THEN + JJ = IR + DO 260 IR=JJ,ME + CALL DCOPY (N, 0.D0, 0, W(IR,1), MDW) + RNORM = RNORM + (SCALE(IR)*W(IR,N+1)/ALSQ)*W(IR,N+1) + W(IR,N+1) = 0.D0 + SCALE(IR) = 1.D0 +C +C Reclassify the zeroed row as a least squares equation. +C + ITYPE(IR) = 1 + 260 CONTINUE +C +C Reduce ME to reflect any discovered dependent equality +C constraints. +C + ME = JJ - 1 + GO TO 280 + ENDIF + 270 CONTINUE + ENDIF +C +C Try to determine the variables KRANK+1 through L1 from the +C least squares equations. Continue the triangularization with +C pivot element W(ME+1,I). +C + 280 IF (KRANK.LT.L1) THEN + RECALC = .TRUE. +C +C Set FACTOR=ALSQ to remove effect of heavy weight from +C test for column independence. +C + FACTOR = ALSQ + DO 350 I=KRANK+1,L1 +C +C Set IR to point to the ME+1-st row. +C + IR = ME+1 + LEND = L + MEND = M + CALL DWNLT1 (I, L, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, + + W) +C +C Update column SS and find pivot column. +C + CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) +C +C Perform column interchange. +C Eliminate I-th column below the IR-th element. +C + DO 320 J=M,IR+1,-1 + IF (W(J,I).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), + + W(J,I), SPARAM) + W(J,I) = 0.D0 + CALL SLATEC_DROTM (N+1-I, W(J-1,I+1), MDW, W(J,I+1), + + MDW, SPARAM) + ENDIF + 320 CONTINUE +C +C Test if new pivot element is near zero. +C If so, the column is dependent. +C Then check row norm test to be classified as independent. +C + T = SCALE(IR)*W(IR,I)**2 + INDEP = T .GT. (TAU*EANORM)**2 + IF (INDEP) THEN + RN = 0.D0 + DO 340 I1=IR,M + DO 330 J1=I+1,N + RN = MAX(RN, SCALE(I1)*W(I1,J1)**2) + 330 CONTINUE + 340 CONTINUE + INDEP = T .GT. RN*TAU**2 + ENDIF +C +C If independent, swap the IR-th and KRANK+1-th rows to +C maintain the triangular form. Update the rank indicator +C KRANK and the equality constraint pointer ME. +C + IF (.NOT.INDEP) GO TO 360 + CALL DSWAP(N+1, W(KRANK+1,1), MDW, W(IR,1), MDW) + CALL DSWAP(1, SCALE(KRANK+1), 1, SCALE(IR), 1) +C +C Reclassify the least square equation as an equality +C constraint and rescale it. +C + ITYPE(IR) = 0 + T = SQRT(SCALE(KRANK+1)) + CALL DSCAL(N+1, T, W(KRANK+1,1), MDW) + SCALE(KRANK+1) = ALSQ + ME = ME+1 + KRANK = KRANK+1 + 350 CONTINUE + ENDIF +C +C If pseudorank is less than L, apply Householder transformation. +C from right. +C + 360 IF (KRANK.LT.L) THEN + DO 370 J=KRANK,1,-1 + CALL DH12 (1, J, KRANK+1, L, W(J,1), MDW, H(J), W, MDW, 1, + + J-1) + 370 CONTINUE + ENDIF +C + NIV = KRANK + NSOLN - L + IF (L.EQ.N) DONE = .TRUE. +C +C End of initial triangularization. +C + IDOPE(1) = ME + IDOPE(2) = KRANK + IDOPE(3) = NIV + RETURN + END +*DECK DWNLT1 + SUBROUTINE DWNLT1 (I, LEND, MEND, IR, MDW, RECALC, IMAX, HBAR, H, + + SCALE, W) +C***BEGIN PROLOGUE DWNLT1 +C***SUBSIDIARY +C***PURPOSE Subsidiary to WNLIT +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (WNLT1-S, DWNLT1-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C To update the column Sum Of Squares and find the pivot column. +C The column Sum of Squares Vector will be updated at each step. +C When numerically necessary, these values will be recomputed. +C +C***SEE ALSO DWNLIT +C***ROUTINES CALLED IDAMAX +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) +C 900604 DP version created from SP version. (RWC) +C***END PROLOGUE DWNLT1 + + INTEGER I, IMAX, IR, LEND, MDW, MEND + DOUBLE PRECISION H(*), HBAR, SCALE(*), W(MDW,*) + LOGICAL RECALC +C + EXTERNAL IDAMAX + INTEGER IDAMAX +C + INTEGER J, K +C +C***FIRST EXECUTABLE STATEMENT DWNLT1 + IF (IR.NE.1 .AND. (.NOT.RECALC)) THEN +C +C Update column SS=sum of squares. +C + DO 10 J=I,LEND + H(J) = H(J) - SCALE(IR-1)*W(IR-1,J)**2 + 10 CONTINUE +C +C Test for numerical accuracy. +C + IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 + RECALC = (HBAR+1.E-3*H(IMAX)) .EQ. HBAR + ENDIF +C +C If required, recalculate column SS, using rows IR through MEND. +C + IF (RECALC) THEN + DO 30 J=I,LEND + H(J) = 0.D0 + DO 20 K=IR,MEND + H(J) = H(J) + SCALE(K)*W(K,J)**2 + 20 CONTINUE + 30 CONTINUE +C +C Find column with largest SS. +C + IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 + HBAR = H(IMAX) + ENDIF + RETURN + END +*DECK DWNLT2 + LOGICAL FUNCTION DWNLT2 (ME, MEND, IR, FACTOR, TAU, SCALE, WIC) +C***BEGIN PROLOGUE DWNLT2 +C***SUBSIDIARY +C***PURPOSE Subsidiary to WNLIT +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (WNLT2-S, DWNLT2-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C To test independence of incoming column. +C +C Test the column IC to determine if it is linearly independent +C of the columns already in the basis. In the initial tri. step, +C we usually want the heavy weight ALAMDA to be included in the +C test for independence. In this case, the value of FACTOR will +C have been set to 1.E0 before this procedure is invoked. +C In the potentially rank deficient problem, the value of FACTOR +C will have been set to ALSQ=ALAMDA**2 to remove the effect of the +C heavy weight from the test for independence. +C +C Write new column as partitioned vector +C (A1) number of components in solution so far = NIV +C (A2) M-NIV components +C And compute SN = inverse weighted length of A1 +C RN = inverse weighted length of A2 +C Call the column independent when RN .GT. TAU*SN +C +C***SEE ALSO DWNLIT +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) +C 900604 DP version created from SP version. (RWC) +C***END PROLOGUE DWNLT2 + + DOUBLE PRECISION FACTOR, SCALE(*), TAU, WIC(*) + INTEGER IR, ME, MEND +C + DOUBLE PRECISION RN, SN, T + INTEGER J +C +C***FIRST EXECUTABLE STATEMENT DWNLT2 + SN = 0.E0 + RN = 0.E0 + DO 10 J=1,MEND + T = SCALE(J) + IF (J.LE.ME) T = T/FACTOR + T = T*WIC(J)**2 +C + IF (J.LT.IR) THEN + SN = SN + T + ELSE + RN = RN + T + ENDIF + 10 CONTINUE + DWNLT2 = RN .GT. SN*TAU**2 + RETURN + END +*DECK DWNLT3 + SUBROUTINE DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) +C***BEGIN PROLOGUE DWNLT3 +C***SUBSIDIARY +C***PURPOSE Subsidiary to WNLIT +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (WNLT3-S, DWNLT3-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C Perform column interchange. +C Exchange elements of permuted index vector and perform column +C interchanges. +C +C***SEE ALSO DWNLIT +C***ROUTINES CALLED DSWAP +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) +C 900604 DP version created from SP version. (RWC) +C***END PROLOGUE DWNLT3 + + INTEGER I, IMAX, IPIVOT(*), M, MDW + DOUBLE PRECISION H(*), W(MDW,*) +C + EXTERNAL DSWAP +C + DOUBLE PRECISION T + INTEGER ITEMP +C +C***FIRST EXECUTABLE STATEMENT DWNLT3 + IF (IMAX.NE.I) THEN + ITEMP = IPIVOT(I) + IPIVOT(I) = IPIVOT(IMAX) + IPIVOT(IMAX) = ITEMP +C + CALL DSWAP(M, W(1,IMAX), 1, W(1,I), 1) +C + T = H(IMAX) + H(IMAX) = H(I) + H(I) = T + ENDIF + RETURN + END diff --git a/c_binding/test_install.c b/c_binding/test_install.c new file mode 100644 index 0000000..2bcaa1f --- /dev/null +++ b/c_binding/test_install.c @@ -0,0 +1,149 @@ +#include +#include +#include +#include "delsparse.h" + +int main() { + // Set the problem dimensions + int n = 50, d = 5, m = 10, ir = 2; + + // Generate random data in the unit cube + double data[n*d]; + for (int i = 0; i < n*d; i++) + data[i] = rand(); + + // Generate interpolation points + double interp[m*d]; + for (int i = 0; i < m*d; i++) + interp[i] = 0.25 + 0.5 * rand(); + + // Generate response values + double interp_in[n*ir]; + for (int i = 0; i < n*ir; i++) + interp_in[i] = rand(); + + // Allocate the output arrays + int simps[m*(d+1)], ierr[m]; + double weights[m*(d+1)], interp_out[m*ir], rnorm[m]; + + // Set the optional input parameters + bool chain = false, exact = true; + int ibudget = 10000, pmode = 1; + double eps = 0.00000001, extrap = 0.1; + + // Call the serial C interface with no options + c_delaunaysparses(&d, &n, data, &m, interp, simps, weights, ierr); + + // Check for errors + for (int i = 0; i < m; i++) { + if (ierr[i] > 2) { + printf("Error %i occurred while testing c_delaunaysparses" + " with no optional arguments\n\n", + ierr[i]); + return -1; + } + } + + // Call the serial C interface and compute interpolant values + c_delaunaysparses_interp(&d, &n, data, &m, interp, simps, weights, ierr, + &ir, interp_in, interp_out); + + // Check for errors + for (int i = 0; i < m; i++) { + if (ierr[i] > 2) { + printf("Error %i occurred while testing c_delaunaysparses" + " and computing interpolant values\n\n", ierr[i]); + return -1; + } + } + + // Call the serial C interface with optional inputs + c_delaunaysparses_opts(&d, &n, data, &m, interp, simps, weights, ierr, + &eps, &extrap, rnorm, &ibudget, &chain, &exact); + + // Check for errors + for (int i = 0; i < m; i++) { + if (ierr[i] > 2) { + printf("Error %i occurred while testing c_delaunaysparses" + " with optional arguments\n\n", ierr[i]); + return -1; + } + } + + // Call the serial C interface with optional inputs and interpolation + c_delaunaysparses_interp_opts(&d, &n, data, &m, interp, simps, weights, + ierr, &ir, interp_in, interp_out, &eps, + &extrap, rnorm, &ibudget, &chain, &exact); + + // Check for errors + for (int i = 0; i < m; i++) { + if (ierr[i] > 2) { + printf("Error %i occurred while testing c_delaunaysparses" + " with optional arguments and computing the interpolant\n\n", + ierr[i]); + return -1; + } + } + + + // Call the parallel C interface with no options + c_delaunaysparsep(&d, &n, data, &m, interp, simps, weights, ierr); + + // Check for errors + for (int i = 0; i < m; i++) { + if (ierr[i] > 2) { + printf("Error %i occurred while testing c_delaunaysparsep" + " with no optional arguments\n\n", + ierr[i]); + return -1; + } + } + + // Call the parallel C interface and compute interpolant values + c_delaunaysparsep_interp(&d, &n, data, &m, interp, simps, weights, ierr, + &ir, interp_in, interp_out); + + // Check for errors + for (int i = 0; i < m; i++) { + if (ierr[i] > 2) { + printf("Error %i occurred while testing c_delaunaysparsep" + " and computing interpolant values\n\n", ierr[i]); + return -1; + } + } + + // Call the parallel C interface with optional inputs + c_delaunaysparsep_opts(&d, &n, data, &m, interp, simps, weights, ierr, + &eps, &extrap, rnorm, &ibudget, &chain, &exact, + &pmode); + + // Check for errors + for (int i = 0; i < m; i++) { + if (ierr[i] > 2) { + printf("Error %i occurred while testing c_delaunaysparsep" + " with optional arguments\n\n", ierr[i]); + return -1; + } + } + + // Call the parallel C interface with optional inputs and interpolation + c_delaunaysparsep_interp_opts(&d, &n, data, &m, interp, simps, weights, + ierr, &ir, interp_in, interp_out, &eps, + &extrap, rnorm, &ibudget, &chain, &exact, + &pmode); + + // Check for errors + for (int i = 0; i < m; i++) { + if (ierr[i] > 2) { + printf("Error %i occurred while testing c_delaunaysparsep" + " with optional arguments and computing the interpolant\n\n", + ierr[i]); + return -1; + } + } + + + // If we made it this far, the build was successful + printf("The build appears to be successful\n\n"); + return 0; +} diff --git a/docs/LICENSE b/docs/LICENSE new file mode 100644 index 0000000..00ce8f0 --- /dev/null +++ b/docs/LICENSE @@ -0,0 +1,22 @@ +MIT License + +Copyright (c) 2020 Tyler H. Chang, Layne T. Watson, Thomas C. H. Lux, +Ali R. Butt, Kirk W. Cameron, and Yili Hong. + +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, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +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. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/docs/body.css b/docs/body.css new file mode 100644 index 0000000..99df0e4 --- /dev/null +++ b/docs/body.css @@ -0,0 +1,249 @@ +body { +color:#404040; +font:76% Verdana,Tahoma,Arial,sans-serif; +line-height:1.2em; +margin:0 auto; +padding:0; +} + +a { +color:#387C44; +font-weight:700; +text-decoration:none; +} + +a:hover { +text-decoration:underline; +} + +a img { +border:0; +} + +p { +margin:0 0 18px 10px; +} + +blockquote { +border:1px solid #dadada; +font-size:0.9em; +margin:20px 10px; +padding:8px; +} + +h1 { +color:#387C44; +font-size:4.2em; +letter-spacing:-5px; +margin:0 0 30px 25px; +} + +h1 a { +color:#387C44; +text-transform:none; +} + +h2 { +border-bottom:4px solid #dadada; +color:#387C44; +font-size:1.4em; +letter-spacing:-1px; +margin:0 0 10px; +padding:0 2px 2px 5px; +} + +h3 { +border-bottom:1px solid #dadada; +color:#387C44; +font-size:1.2em; +font-weight:700; +margin:10px 0 8px; +padding:1px 2px 2px 3px; +} + +/*** Main wrap and header ***/ + +#wrap { +color:#404040; +margin:10px auto; +padding:0; +width:970px; +} + +#header { +margin:0; +} + +#toplinks { +font-size:0.9em; +padding:5px 2px 2px 3px; +text-align:right; +} + +#toplinks a { +color:gray; +} + +#slogan { +color:gray; +font-size:1.5em; +font-weight:700; +letter-spacing:-1px; +line-height:1.2em; +margin:15px 0 20px 35px; +} + +/*** Sidebar and menu ***/ + +#sidebar { +float:left; +line-height:1.4em; +margin:0 0 5px; +padding:1px 0 0; +width:195px; +} + +#sidebar ul { +font-size:0.9em; +list-style:none; +margin:0; +padding:0 0 15px 10px; +} + +#sidebar li { +list-style:none; +margin:0 0 4px; +padding:0; +} + +#sidebar li a { +font-size:1.2em; +font-weight:700; +padding:2px; +} + +#sidebar ul ul { +line-height:1.2em; +margin:4px 0 3px 15px; +padding:0; +} + +#sidebar ul ul li a { +font-weight:400; +} + +#sidebar h2 { +margin:3px 0 8px; +} + +/*** Main content ***/ + +#content { +float:right; +line-height:1.5em; +margin:0; +padding:0; +text-align:left; +width:750px; +} + +#contentalt { +float:left; +line-height:1.5em; +margin-right:20px; +padding:0; +text-align:left; +width:750px; +} + +#content h3,#contentalt h3 { +margin:10px 0 8px; +} + +/*** Footer ***/ + +#footer { +border-top:4px solid #dadada; +clear:both; +color:gray; +font-size:0.9em; +line-height:1.6em; +margin:0 auto; +padding:8px 0; +text-align:right; +} + +#footer p { +margin:0; +padding:0; +} + +#footer a { +color:#808080; +} + +pre { + margin: 10px 30px 10px +} + +/*** Various classes ***/ + +.box { +background:#387C44; +border:1px solid #c8c8c8; +color:#fff; +font-size:0.9em; +line-height:1.4em; +padding:10px 10px 10px 13px; +} + +.box a { +color:#f0f0f0; +} + +.left { +float:left; +margin:0 15px 4px 0; +} + +.right { +float:right; +margin:0 0 4px 15px; +} + +.readmore { +margin:-10px 10px 12px 0; +text-align:right; +} + +.timestamp { +font-size:1.2em; +margin:-5px 0 15px 10px; +} + +.timestamp a { +font-weight:normal; +} + +.green { +color:#387C44; +} + +.clear { +clear:both; +} + +.fade { +color:#c8c8c8; +} + +.gray { +color:gray; +} + +.photo { +background:#fff; +border:1px solid #bababa; +margin:6px 18px 2px 5px; +padding:2px; +} diff --git a/docs/c_delsparse.zip b/docs/c_delsparse.zip new file mode 100644 index 0000000000000000000000000000000000000000..e06533e396ef1f332fb31ad13a50f5d1165540d3 GIT binary patch literal 103216 zcmZs>Q;aZN&~DkbZQHhO+qP}nwr$(C-Tk(0oAc$*$(fv)bFo+IX4g$6JN4`=1!-Uq z6aWAK2mlo?2SrZd3rRF0008}a000C48~|f|BTG9IOFMIVBO60!Ix|%jNC4pa>n8n> z=O%qu4`={DkaJ)Ffd9b_ucrHx!u1Tq-&j<d2spjr|1CXtk<1f8b zEDG#TXd{Hto4)slGrB>}j(GcfAJ?1R&UX_x*qsl(XIz;($$?j2w?+qDU_v-<7=8BK z$aj8hZ@l3ex8L&ahkck!|1b$AI~2}( zHdG2%u1fgb$mVh~p1`GQKzWWTt~P^j-)>n2uQA*A9!ZS*u%gayJjSXfEH$?X%k;kT6iDiXjxVE)=C>AqEK z0aH+;xRpo^&7a#rCV|F;`ZNH7J$`{ZU4zlrUx+&Z#^w^*e%o?}kIw{70o0a=LOYIQ zAV2sGxHLk4frqRRG%_c`z$|?&S^98rp{0^8uIIYn0w}fh<+MmL5<9VJ&H@s=2PWTB zSIF&huS=`hv-BH62OShGRVH(}!OV)F{RGG2j!(|8+3X)nSFjmMAiK&cmPLDR{tu+>hIsJtB49ZvN(Noqo?OqfWrZs z9@Pi*_0Hvagc*?Jz4RqU>GI#Ly-EB$cFAFe{?;U2-R_@mrClz%@9bR$+z;04awnA? zZRSb~C=qO)rUXWOts^M_lUNW8l~f_GKe(sMn=obb4n`|r5jQZvBgBNSo>RhkE4EYe zxX5S*xYJ3(Yq7>eZx~yaUGL4KNTVWv^;)s2wOYFuq;C+%B?$f~FcyVqWR@957Sdo9 zz1=9E+V2DAZ~|;b;5}w4{xZNFCC}w$eP1~P`!}ckCFcZIEX%Z5TDEM;w{RvXVhx+W z_3Xta^39U|(hO1>%DZR|u-stj;!DolyBd$^pB9rt%VZKzU5-USwT`0g^*7eh+k^3T zL(hh(6K^leHr8V2BK~rJZtO<0TPn9c5I?dtegPAzEdU1O4AlP;IRr=pZ&)MV*hG`b zC!0P;1Gni2#Fp~s%aRFzrr1VvRMQjj<$v6^se&t)a;*qTlPx&GnS^0Qle@=!QK~y* z^yW-17c2jDR}w%>S@0@|K`Mxq3S!ol!CF!Y^T#?NU(oYvln|GV*3|V=sH97fDxMSI zBC{e?4IW!kl-OK<^>}|vcR{UifF@gNigIA0`ZsCj%zbw<4S;sXeuA^KOn=)+i6H+L`GOIv|1{JUCy>z z+Jsq7wbJqaT<|verlepnslc*Tgg&J1s^Pryemg8;>R`L+vt00}NnmSpG|Mc2v+xJuLY1;;_KrEKr+CtYHWE^;Cs_G!{UaUK)m@Kt%`qp=Ay+7xx(GqoY z@%`vsZ=09=)aSW~%EJ|s`R`!(xnvmbYg&8GL@C|y$?y&9-6|G#S>?m>{Py@VcKg@O zG6(A{Y^RTh9ro+<5&qSmIuQN~Ne%N`Ui682LBEWyfWZD;y4(7@+?zIJ1eIY$6dgf1 z5M3X;q0@i2_^$tUu|HWR;BgQZA~bkmHPBz{{wyfLpwDH|GCV^4-siT+m+{`$#=auLcSj(Fyo2Hy^l>(Gz zLuP5(5?SaEsUn52HryK`_gsC%vcS5Z9$pmGH;g=-j8 z8DcY;!{{Hk>Tee7Pt2dPDvrSDO3!-(tfkgNW9>|1ZA@b%5&$)RfEiK%bRAA11GD{{hr(ApMp>3@V)paR$d+`|hCakvRObqIZ6;Fg1 z;W{<9iZvm(O2rhFs?tGX=4X2;xPC(79w9_Ys5`eKX`Yx^SAp0Wm2)C6muSC z5SNv6d=Ayh%Dt~K{ne91LEjRy+yjC9HPr&q>+cen?qe8K#%bOoBRwSJ2;c@iKtm}k zK~eFTpW&(+Th7;q0~z0-6J|9&hcg+SxjY@ee#EjOWf3xV_;V)6$v+!D(1{6peN6wA znJmy6_bV{DTHSPhe~=`($ApSeDkXDpQH*jA>88;^y)HSd_M#A>U?4DSymU!Go$%6q zDTiT0&if=9fjGD2h?Qh6DptzhadR%Q*%1A+mb>EbO?TMV$z>$2aR~r5j2qETX!`en!M~4jRfMxlWv^47E;NQsD{KNB4{|LpE}JTZswOMoZ^yCr7z zkC9aEvWvv(IM=SuQRa2`MmhVJ7S<+xVmoGeZFc7=DcfyQ+3gfmh`>8=v*SEKLQjgr z70A=wE4p}z2tG!TxLp&(7pjnD>?Ej5^4(yF%eDa{z+uqIsx*$9*Hiw*?&K3@L9_T(U15+Rebu?-1swrpi&gNR> zJ7klDK4dxTP!vcE%T^F2W#dvsa%7!vQBCFdf0c6Xe8)-S;uV!LON^Z>CU%OD@<;B>NV; zeiBXV6&d&w(dax(ChyGt=x2GOM8u6WNHIhj$FZX8y3`{fHL4Fq9e-F z<=o(3u-IlCa+My|EkO3M8Srvo_NmUDT;jD!ERn2$Y6o4UqSpjNAW0F>+~g|>3ep3O zXF@wY#vyHsIwl0MmJMDNv%iCk;M>bKw|YY34c*sla&hpWxbllH)yQ3bfo6=rz9}0j zunuI$+nuo0LkY|5OPWcqKCk)+_jACO#7c!*q)~?noS*Xyr}c9#mothwr>ecLWASs} za8_T@nf3{MGuSG+o<4*->~?~CZKLWj&3(4no>jS6<-$iUCONRN%nNPZuLytaN-^*A z_pln%Mp-OeO5IHD`el2tZcAg+F0@uhD=k^4*tE)Qb3VnUQ)8ITLT1>&@X0qJ+J>hR zl-Z>YJTo?n5aoSggAZ@`Rt_>7*se4&E3v@o1aFxGp%gCKe}o<|sO}Gng+bu@;5wK?%wgo_ftR2W)8XQu2V>d3#rZgI&oC)|4PyH3i{DRittY0N3VBFY z_@q;0R$b{O)dmNR!dPrpl_oe`Ox2yY3C{>h?=b8yW3qU?)BuHa1?H2D(*?Dq?BR(q z?4puiMW+~RCz57F?)@MJK;6YP$h#~aU(`zij&sxD65PfmJqOGqc`i85v|4hHg~=^d z4LL7SjLXuIV4cRg;87?` zDbmC^@^SJL52zAptcu!WPXg;iZ{2aCw_Qk?haHG0RK+>&LzDWJyyFpT`G3{o1B8roL(Ur#@-TY0%5PoXST7l7iJMEvp-JJ zm31wWV{!T|2ib-5G56&~g9SoS7Jfw4JtIokZSS|TE=BiHGklqYPH7RRDwc|il(V9T z5n_<`dEp;nkxA7Bs9iWzldLtToU*0F60H2QFA-h!WL0HDph1$A4kyPa4fXU{sQ=z4 z()(U~E=ZS4m8b4`gE2{VPCS4-oP7?D#z|zjWwJkEEDGbGb+iLs`K~{~2=Mcao&4CC zu2A{}(fwzGp*(j2=@%~DlpViinH*D^M}f{@k7J)inKJPv$d=8{?}?WT1X9QPR6wh`xTMXL8C`@n2!S9zTc9gZoxl0oW&5JH)8mXO4IOZoCj) z2CN};+X%}o@F`eeL1_IH2q=f8c0$?*NHzIB=SW=Ne?)H-={On}j2HEDE>33%Q}Nlw#T@UgF>s zp&W+xSa;u{tu?Dzo3|XH7QLdlIQ>>^B)<6z!rK0Xyr(f_D@jD)v87G`pv_sg++ja@ zfQ-Xn(AV)c@a|LFCeWu}r6ye!8LAeQ5AfKAA%-+1l zT}rINm-AVFKG&9=EO-7Mmq{MB?qTUWE5+42T1dB~*}ZM2$(Zb6J*(t%OU^`=V&K>k z-JS{HOz~)VjMbjGQhi)7$na+;Z24fG;;ERjqM^Q=LLV_(+q@Q~$o$r%v3LK5dp;+I zB=dhsG&vHD2CVLL$3*UoW>>QDCx`fv?0=_`?CmIu%{D`_u)4jhfxEjTd^5JhB3oih zmaLH|U)(PnxaBb|Y=tl_M#C^|N>owaU$Z z=RwhzL-O)BdDI;Q4(^%Cg5d1xFS;WwBKAl&PU84#ey0rh?q2&G~DHkJ83Rqg-+5iBdJpjGh#Rm30@o~AXzAt zgxXggZ*^`)!o4yx%Q{IcU*K)F)J>nomlRZZnJDC@OF~piSz2D5KA1`K;Hbn5*_(sZnv%h*(W0yJ$;ObDwMt8g(GrkCI1snlvU0 z93+%VP)i=!s>{=4o{g#;yP2FEN2we~s$j&gNw-#@=|{f9FcS*|LyUV+r)AOP+9Q4) z4H0pFo)XM2X0LDV5u11N2^z6fJArx7vZzdvCKg=LaMK6^QMf2^4L^kkeQF2=X;D%5NoEKKf&;{ew5Y?K3Hd6@!j<*Fx)1~e*aEGLXiDx@{1S4bqtgqZS6`>sVo)x1D%f336p-3w)V5_B2$_^LmJGL2~ zb*QKNG%<>Cfa=fUY8}VmQWqb{bkaSPQSRtPmbczX`LCBeHJgZ{ z)Pu_h&6YoT-r5#tqshaw)t(yRr_2 zMcDZiLoCyX-5f>ME9)Qn*e`r6!#zuv6auJ39^-3y+wEmG?~^lq7~8nZ<>rise&$FV;+Hs`4-p6 z;2~xJ@2PR?bMJnwoUpJbJ^ijpkfcB9pW-F0XwYU1O&LZ+xSx*ut*hcNL3u{X_g@MYuwYNg4Nye0FH*c^BW} za)Z(#OW;-f2AMu43~jgQxTQu1`>{eMl-$E$yr^(}8mfLs25_D~2+AbjY%$0Sx)Rq* z9))N-3e<#UQ70-ya%NDpTMlFzh+Z|xO<0bHaPN#OqsAkWT!d2I3J%e`diq9G(p*ye zyqZK)tQIIvwacdmc+(uNSXh6E|9oK0J ze)nYCm>eRm^ZQe$OTGyISioI{ECe6+qeab`u#vlEtOQv(v~>l^CiYlgJyg zY&bxzPmTuEd&qP&jP;jPwpSuef|9e8CKFo0JL^OO(pb^D^5nW|+)n7A zeNzdzm4`6ub8vb{W4_79a|qy>GgD^o0RF<*1AdwW3mj)Rs3?GlJxK7TqP46InZ+YA zasr;?UkKK0#b`GU*&QlySbIy*iDiKNU~g87TuLgKgP8CTs0^G8hAravgze#ObhZJ& zbLZQ=1icW>A+A$ZHJfL|;v8r9f^AcAnW^sTX;y3IU4=@Gy+JIpKT5Z)cXRorQdQZsdROJEyb^0jVz`~7ztIyV^ox|_b^N^^`Bw+c;h4nW zHvegyai0?^6a<~lE@)hCUxrp6$R+`fXXPr=O?2O*&`ATjewWndlK#2cYwAiPcV#nu zY1kr4yApF+S=GN=VpLV=cPJu4;3A{h6b-jV+Q?(QPbY1agLD;WgxPSUom!tR?NOKZ z6&G`7gp{+AbPIWIbCg0DNS4X|6R*@S2kpr(hv9m)3#@-fJNCCXJ{L244CGIek=8Z` z!b};nqoVgE;VoA*cXx$uZ(Y)UuBY_3CP|)~v^C-g1PiI0o*95V@ynnea1DG9E3+-C zT&>QE&9(2!Kg>D_B1iEc$UxWs0Uwf#4@t&`cTnVycyNTDWH986zqz?lRk$14mKIU) z`3R_GI2=i^T`}ju%1^M<%tyN5i>XhQL<% ztAy$(cua}jA4oMzl88~BJV%DM5Yi?k%V>wTK{bQl!rQt=)hb=3rg6=UZF23GyEJW4 z$GDc2eFbERttGcj?Vp@?p21xNFzTTqHlQi zgn9>6%3}Do_wP;+cFEng`T^vyk5q>-vZqVlqM^xUkJs`^3P<~j?D&c%N)e$Qv~)vNtyz?d4n5>gSsvuD9Zy(m{+8x(>P6Even1+%0l;HxIL?p(-9! z6VbSf0`oSGUDA3AwMsLM#I(K$>38Z7Z%Xb)n{2Tz!oSjOK5YKk(@r51b(A8}MP;MA zVu=$aG%g&SJ(nvA+kY!NX3gnYiT}-C{$MJd-0>1js)9pP8Bo|f# zj}^BIl7W?sixuE_97%kX8XPT+f2h0t5}OuvX?B3%A#B8IcBC97<2r+@;XF~Zf8FT8 zXH1AQ?REm5^E6xn$|Snfxsi`#!sgh6Sp8-Aic4fVeOImJ966&_Io zPj6R-;fCvm>9Po%80b#d+|i`?0(9tB?*Jw}`5hlS05gk-{;Ls-uRU)h{eT8CrT9%S zAm7%c@>#H8TgIjy&O`xknWh{dJmVPsfk2hMw3;`D9jag3II;h9kj~!*2(+N^!mq#Y8aXM=Z`q5gsYeN<(LAa&^)3}zl z&DDp+(PttmDdENil6s@TJCgL75X9YHzDiBmlIIN{F;I zW_=)b`z}fDeU3FA2*-o}Dt8x`Z?F)+JixyM{^^@_^m9!^u;}YLPNQUwc+V2g(9;j$ zV6y;MHisPsVMw!(LbHo@@01??6l2)X z_!Sbo2tkZh;(Qm=8;S05D@5;-n?zox6DBT8MVJkqB??cL7eR7pD?*Zl1O0r2ve}U1e)AU^jy?r}X##$R_WaOS za2@2xW&JhoYQIpMkR{lsYrr!KiK1j`QkgJDUt~|{eeW{0UoAF4xsUxVnC;iy)5idg z+9Yh%$^Zq!58wu4gmup$M9;4ljNVJu=jn304}SIRud&YEK^8CrUy!N1wih`!7V?d< z$lC<)CI55#(s05ydLmoAS*PFq!Vli- z<-dTl-LYe5&%t5GG2{yJeHsx*T!+JG;p%liemA>zM*rTjdi`d7cqd-;{juVNJ)W-6 zxNE8Bb8ioX>Dj#DJyWKaHF+%z3;ibxb2lV2;GdUKzUxAz%qXYSI1ru@{*fDjoGA0e z5ZNo?adBfqbi~6=$aL~2!j5LhlY4Tu)(qB`uqTNaqCg3ZM1;8vyg!z{Lh>x<;Yd(N z6E#FjHP$={;SsF$-`|B%R>%SyOUUXq6h-awQ<$^Y?V3uv66E!+_o57#(cy{Zdx6&x z6n~^yGKX`>^EdZ9^<3|N(tx&&f?_Z}zvL1@Os|gFMi)5~1)^j$>~Ybb`tWH{^9&nG z$^}a#4@$wPe`&XR*4rG~F8AKp7nEKaw_!`>%p<5PmTDyTonBO83S&dohaQN}Ve~Z} z&KVO2;tPe6m%dV#;gYnV%w*3wutETkhB;bzXNNaPGLEN!7~?sDua9ly!UEOiA`XQe zi*cX)VMi=pqZ*a#-;>E=goR5X)vsq&N};DRS7iL7*iPcu7c! zLV}^}OP5%goWdAccI7}6t>s=rBX*nbtf_}LIFKmV z$uNpnGHt7N8wpQ~Jb{P2jhvW;*;-nzEZo#^JXMX%WB}Ds9mkn&_KiBO0fV|G((=)Tb_eU_l zYR>0&ZXUb9b{>B8*c(wDnxO50FR`~zO3CS3+w%3z$X!&0E1M!U6cu4~ zT0K;K;Z6!Yn53p5v`>=)l_rYqzgEA^736x>bb5>tJLL}L+#&Tpg<@WVc}l-fGTcQG zt6BcAAFugABW{Ju?j1gcji6r5?;sKNt*tR6 zJI$b#ckGQ<(Z6)pSGU`o^|qz!Yq=*Y=+UZ4)#M{OxpCH!rLf9@mO_V~KQo zF4)*T!-;f?pUBgwiw2#R?)2z+oukcB3C|V-?#Iqn(5+n7*1D*!T+yx*L#x{N$wQAd zZoamw(I+%q7L(6dyZh9asT~7EZ6P%42=99eu9vgc@3(8{m#LW6T@zL_g4sHRr{d*A^Mjq(RYooS}jWW|SRY z3780}WYSG(@O`cxus|PmRxor&Dp4LpS2e%`@{>3tP({-cQq{}>!mkbQ38PL|1Cvu29ITZK8%^`P?hv;LlajR^|Y}%lb5rmQL z3Ug%2hWJbj&OtE=W}N83O!25`O!bQF51Wxg^hVC4azOl06xOSS62r^LH-n~Sg$4q3 zp!6vWaWk{X|F>2_C21V$IcAalh2AtKfhsJy7>&vRDjAq=wQSwvxDX9`IVQ;!$l|xlgqvNCc?q!=M=}4@~wOk>ghUDG zc|jDtizVi0`9+iq4G6kWSqKJ;M~BM^YuSTzC+rIfHU%u0iQy@HJ3t=FRzx{J>oI z39*KaFgm(8K3ezkTI3Dv0#KpKZe8YiFRss6oeS@WZXU`1;vOuKoXl&BNnWSBu{*t2)gX~}QzPpue!ZRy&sKl7cT4>3|hSJYc z>1kP=S?A0g5lI9j&?(#(Yl5v7z@ys3ODB+5LVhH`=jGFLdudB^q_KkNQ*HDo|Eeo# zGYnhcYO&7MsK#ur1>p@)G3@9jKqeJy_WtZVylEaZ?Oh7P%c@pP`lWkX+ zGhr35WhSQceKNH{Ts*M8D#dghm!cQ661%a7E6_0D44IClx}wNQt5vHGEK6OvvP!cwM0poQuF= zcH8FAD&`Q5)Da^yTVDE-;4e|d=b-ZLYj{?@CT1&cZY#O8M&eJ699;IaypZ0sU z*gTcU5Ib*2VM_Q$<4awf3oC6v7c;K-^JF< zAlkZ9FA6p7kH$##60(=wJIKv^xX-i`lpgS^E(fjprfL*T7#3}=u>GqkFM0T}7M~ z4*iu>O*6kn)ALFgehS=su zTr(BbD?r}OgbW37Wv)XaqiDrKUBS_2^icDx_)p_!9j+!0DWf%VU50ji4%9DSKMur3 z&kDGhlW1~KJiWW+8xHLZkYcC2wO!Bqv|)zcw$e&yNA7N{_jVhm|G%YbY`>oQ7b=q( zo1^)l*Ef`hCjF8A8?y-w;LOdzZrsop^5?cmrj11gI-gih?7#%&f5DSmKcb%MH%6H@3k&7d+miBE>`0@X2%B~mo5ZqIYHirt%A zw|o9Wpl&ad@9-iPU%zXxzYh=q{CgbwU-=xmn9d&F*Rxo{E*w+8yP*|wP|lw2FeZQj zYzPy=i11n#&=4FxsHVt(_S@o9qb{&E(!RIxa7eNJbP9?KP^Nyd+q}1-NZ|9&VW8Lk z+M|t{dnS{~`ylWO4}1BDn;XOaKfJr3@Zp}M%8Oq-Tu}IMLFLB{l^5UtA0-aOsldYl zc+`gjLfq=(D82o$1Y8`B^Kl08I1cA-C~+JP{ldpXU23J0*Nrhd+!aOa9Rd^oOti&w zjGy6%FUI1xIsc(idoyj6WukqV=EGBneQaKa(E$5$&vFakuS~do*}*pST<`w>9sfc& z-h!OzIo=L;{7dH9mmMA_<1>AlNFhW1yT^hd7yQ4F@sO!I9CPEkWOnaS!?7|Rh7 zObz!Slnp$4Mv3~y#lEegNqdj-t_TvUEICPdx!fN^Rvyv z!NqTO(EWE9)Rz~Hag~9WE zEuWb=Xr@F>IB;c}kCw1JP4kF-A4g)EKF!S7*QXoAEHq6{pd@?panFZ!a$?Je+e>+2 z5e{wKr2o9m#|%*N;`q6lAV_p_WXqyI86`b+4_~aZ{(257JUX^zn6#JC)YXlTBH$tQ zJV0W7dvVR3j=BU5)Ro`=_gWobJ3q$9byDn}BIiZ9!W9bAR>f>hNwy zCHKDCy*2Y=ZV%_>5))~hHWOicdyFgFE?Jk;yUW4p!+HJKef!S3V3q9&s9>EI7{+0r zwzxZh_IV|y6WhDO|K*qR$ z8*tNe^Sd0p?3mkzZ1}G3;+EjoQa4;0vCSCz|Ct9rSHo*Qj_H2}Yt`$s3+#6weL@UX z5C+=k^Hh4n54oIcYSeG38CUm#9S`ar;MRwf$uF*f$d?^lJ~f5A2gUx=(FVsT1HJNO z32?Q&JCg3&a~GNFwb}l6KZ>gtAO31Fwe4;|G`Kaj6U|_%v~u+fLfPm_k2#yb{`45ZM?rni`@ZD zC-QfdIkt#Y=Ge7|=i&~W_MqI~pO1iXew6hAi6IRBw;cM{9;rQ`6DQ{fP=a-u%Ddps zu^7QAb6q~1j6Ptn-+$-sU@3n8vK7ol7;M3bW0~+QS@uFabD=u;U5?ckgRfCgzu!N} zS|&PJI!e!jNt+N#ocQ0Md_g#4)ZXyES!qR9YXRW?rd47@8rk}%1WQCQ*JS1e71%c4 zjii#;5@r4T^kASpOnj{C0&~imsS*4TwFv&IX1>}cgcd#FfMw~>zEzMFCVBw@(w{~> ze4_WoJUMev%|9YSUTl(L?f){1BjELs9%Y|uEZyhB`U(=jEg?R$jvmmb7xuwqE%i>&`1MuYPu*{x{T}dvt2x{Q( z$(5;h2s|B9#iJctG3KG$3!+b+dOBe?VNy^x+qhYa-M^NM#IMsz$D>3PZ@Ofh5o_!r zy#eW4+~ExX3eL>jx;W*{KSJi5VflZHUP<;w#siR^u%Dh?T*H39Is+T_@`Pr#n-|ao zwykd2WRMfE=^UFTrz7KYins{wY$o+{ci?kW3~M(~)Tc%RbS@R)LgOs2r;|ljH~WOy zzhlAIfK&56GwkNo*2)#Pg07Pw9@2!X`enzWH>|2-)=Y6b153jigfBlFS}C!~lF*V~v8 zaOw-0^?nUwA}1IH59fD7n<3y-F>xLfNx+J;1f&DNPKltI`QUSz3>nSca1F2Bb063W zz*qXx6#z>^Myxb#4S;6m$D12tF<9P(8H6(5dV38FaAX@-PTVd|yYl+v{tI^)r=>7i z+w@%2v`+Qxi`6w59X-vNjsNJr&JfLnwHRy2R3ZTImbTE%C9L!~M>zziE<}E@7Ko;v zNP0j&qL{9>Fm28(aP5-=C_gpj#3j6$Q@$)zXTV4 zx7EfDs0b8+{xNgL1&=blx--_l$tcZTY%s3(G%i*1?**@U4cNI{@TSLe=z`MTZrgn7 z4aS10-+(>L1m{41c)CTJkR9>91iu@^9R=$j{Y2ms99 zaM9smDyFc8V*}0uNZo7qFw+Yj?3hq3_aoIh9Q-@VRQ&_?oYSKc z2p1lDYaEMWsGw(02QA=X)`b!8fV-d~k?#~=Zoyj+3G~7lM4D&PoM5J+N4)wOBmUIM za&tiIsQv`ySqKHpEG|o+1UvXRhx67uRW|C0lHh2P5cT+qMn?Ypl3wfp)K>81&R|@U zhC%<}vW;gVR^qEXrV z0LdTnMwoxh#tK_ym`rWmT07kJo2h)0e>UE^ z(N&F^jDP%##RS@y#y`Su@8^yotO&0jFzcZer7*>cbK0^pHmnP8bfp zxcN2Vg=i^PoXnRtZjA!n=9OM$&K50gUgS0fO;nBbbzCS$VZXD#NiA-~VRE%~ z-IUuS>6#)Ku}BO^m=l_Hpg8&)9tX_MWIZX$P;w!AnYQ%BThXZfbYAB*oFia5kY4hmKkUG)tx#HyKT}VQl9rT4Yjl_hx4FYX(3fn8a zKRNaP*>qjel|@ij2E4Wdqe`WL19qX)7M5nQKU6_<4pxB#waAr68!k5k6_F3lk`)#O(V}`;t>FJYDTtHK_@VV&R?02^I zpoWI2dDwg^fMfPV)1p#Dl`w8@dFBCMMtq^clTb3t8c+zW^+F)(o85<2j;%7THH|Mn zwscjI1PoM7)jo4J?f@+)M}_q)hhf9xp?4WYYvJa zI7_~n8NLkmThfaYmVg;fs_YqYE++>cvfWRw1<68V5uuBbc5WpGIg}aSJFHADC0ENn za`8_jZR{9akY5#Ar631MqOiRsbYw2x)s+z?D&bzg0hku0_1ghcK({#h$gJK%4nIo%!hMq}6gXceJHJkOEz{QN|}=?!~AgVc|Lk3Ib!sk+8T)IenbqfD6(%bM=mP7#qC- z_CBmC>bVaAP56N|mx!<8bqv-Fk5vr!kN6;`lzNCFAD)3Y>FuRAEA${<`?^P;ptai;79fdCzq5pxHezuCnm;49!#Mxh zDZKWXcx!-xI3sVUxMGV2l1%Ds^H_&C^CpJOx;fYP`fu5;VOL0BI`HLgn;fy1vd`p; zYbx&YVd*91cYK%wp3(aPY&sEsxHvo_@s04BSptL*a##R?9;aTQ){H>dkB^GjEi71I zb~QvTor{7cOehq6yO_btj;ck9-_M$OF)PkOg+h4vbASoLiR2_!-Qw^)@oA5N#o2Jg z)2sQ9tI*}e^wi?%oes0NgcgHFg?R`l6h5C=`HP2uHw5Iw?h*xCW#!*@kvzMSV@=n4 zW)bFzBVbMpLeqHp1=j(b&Jr;%P`V4uHErH7VR z|? zUo}tKcQR&#{{Uf6N5jML{sX}Pm(@K9C#v?gge@VL0vHiPrD)9XxFdgHPnb|he8#H% zI2AzM>o~ooZXbs?2O=ILq&H*WV1Oz_{7h&Xynk!Q0Me?+_A5f{ zt5;V~zy-l8RWBN7#20Mc^V5i8!n0dU0SDoxRdXgvcN&O*I^u^r+4kH_0XKKr94VTk zU!MNo7K2wR8fT}EW!15rKDXhozr&k*0+Zjj4=-*})f{f_@`0BZxY7#RII?xHtq8I% z2T?FWYK0>Pmw&n6e0We0&wQeyMD6qnYu>&NsFX3Cq2tz}07JZX=@<|MpgR(*Y;b70 zkGw^WFbvM1J&7&@=LZ7=zxu;|29JV1FFgSdr5fxWc7+7AStG*htlHNj14xj$^;>F+*^d_ z2L2YuC6Ok2hRBZd+nyM5LTo?=OS7uG_iDGu`qQdJqi=A6pER#sv|>Nck>4zUL$S1k z>G4~xY;aG>#wBEqGNFN)?VBg%)WBn&q=^doE)8v-6J)u_6RTH=(GYuFlKkPm{8GOn zEaIcyl|91_#o>3}ym6&mgu&m+(cQbezIVcLGC)|soHd7wsg|*v zji21HLAJXquu8?76)Rq{;TI8k`4AB=^&ofk%K|a+xOMN=%|*w-9cH!{-z=$r@#JPL^{=xkyeY$H31a6%qsF{L@T-slDQ;dYi0mdt=RAT0-H~*d{V?lDV8`lg^G$47DaN&N_J{OUbv5bzzy~yb-hC8k_q7e{*a(0d zNciB;6!ROX*1`0odU>79nBCJmDP72T0fwOWT03=GMUwX8L~@8W1QeP%%JhonyJ?`3 z=g@oo;LMnNQBOd2(8#B1bV2qc^Q;09^#M)0Y!2{-vY%j^@lFSQahH{h11-zq!epR6 z47(j+**Z%LLdbB|K$ERrx-zPZ!r*DjSzD=5F9%Mx7gZ(jwpUF|S$-zGZtioQB8Z_~ zT!E!`?;xL`MDe_tQwCnCue%Th+IS7?aS+fRn0E6_iAg)sw<-3w#hpOsIg?dC;f!ya z1-EOxEbiu9T3k9C6-WW|%tIJ*MlhDsnzDFG&FTA=v5L0DFzxP zSbXd(Bvh@=H2F}D5|a76f0}HZ90Vr)-j=}i8s_gF+24rbN|NoesEb9&9wN|~u6K6N z_@ak*Lpgza=jZ@9wl3!!#9-m<4WqSq2~c_L%ueD!#!n-ZM+naXffa5eOdHpeq&3+G(`^noU1)g^|8K z!>R5yel;eFu!xF9PUA9HQ74|%Jo0vAYRf32m1}n&UB*RugXYagpY|eP_Jc8=zAx)% z|Ls3viXiC0l!f_Nq(t}=T!=uywe3Z=?>qILh!yhhH3@kD0RsYLxj5SZ*#|4nzs6&z z7(2|GR(A-$6@^*I6|g(|1jGq?A!vzo5<(1^BX!DsX=PaQ(SgfC@qSK;oN&hY8==W! z^IB7Oi7z1cuLId(a3oIKu(yD4R+HE4OFKFxx~$1aUz-VXP#xQ(6zAoUb(AMTETE30 z3b(Eu4mU@k@faRAYAS<0i*zNGO9372L2Qc)4^Z_vE?c~o6WQ-J&8TdzaR&nC4pwlR z3^+XSo~;8JTQ8kn81&(r2)-h(?2ZOarD^zhVrVM(##qgyjLh&(+~$a_UcDLtQmy%c z=Q!x$a*tHe9SAEE5@zqpBAs<<)rI00sFkKgClVE(Px@s~W@(zo{XQ)Nbp-VB$&|O| zk-47qy75Q_R+#T$UO*f)*z`gTqDt%%e(=s*l5}{vY7VoK$`$fd({&T0O}sb-;9$2h zckDvf2>Oy)J4Tw-J9%zzU7--ql`rcbV(j{^)v1m`Ug!qyanTN}4$nRVn6Z90TDK}W zqT@vdVjp05p!l=500*;?2e}7P!huI{fs9!kF@}aZ! zH6P6L?%A?&=L(g?Fkd2m00 z%JgQ{^h2@Eb4e$HVj)Ce0g+A15B9`&-;1!4;t6msIhGo4{q;FPWJu@Zl*`wu)0NP4 zuSheOC;GZJj@BzkPjsogkPql1|}sEsz`#F%B;hs+$W|4}6Uz4^Sr(=$=4plkStC<>WoSTNmOb$m~<9i{e{n0USO^)NOhObAYd ztQh&Yg(&K=Ntr1AoQ*TY;D{zru0uOyHJTe-vbd^QEQzu62H#;|tIHW~kU8f7ud0 zIB(|sI(I)3(J_1@54WtJ>*c&d;1+^H*qIoMAnO1^6Bf-uB`QP+v9c@cF?6N@C{~=- zOJ{+&yb_IRNT&=$eO98nhz)oGDLJ4cl-d>wF{REqM)fV5;2wOWjjvmpA4hc`1d`vw ztd8Wo$>I_S2`_n84{gTZR{dBYfVf%~J9zW{NKzpe`C@rlnI#~7B7W%2ZJz@Fl7i;;|Pqq+yKrwHF5vuo|?3f)DC?qG+sFswhJKQ)~%daXx$tY`3 z2+M10J|>FHWu~V^jAt#hPOm5a|eUYtVRLt(ltW z%{x)F0X+A4p@A6A>XS`#%K(#^WfcK7{X|(BwJ1rGoRpjRb1la?%dS(G5_XK-Al)U7 zapb9M11D}Ja@~2lv7GJXIUXyW?a=n17ikcNyZspfnp=3FJP&HXIa(1z@P=nS|zi!w%nhTKH*Z zGmPURvLK8jjTRdFh&uKb>}D_yo_RnsI43Ntsv#6FTbF@S-0p|iKmGkjhj9B~I zR8%^oVni~U?Fx>nyE&NF%*sj{sFNJ|nKm08m){xw8pwlG5h+GLSl~=sO&Qvh@bggw z`S*C%>=sE22d6H`Q(@>7f-moW#A`GJi23_>EeT=T5v{5Ps4wLloxyU6z{asCU9tH!s?*8^R|1@cAM+SE^V#TR% zKmDC&d<`P(M8RLz+A=<@uZ{m2a@FWPOAG(gk=tF7jBF2`>Hdmo^ffHlE&FRZ8ba`*rgw)IpEsin{2h!7TOV3HEZUNERe>u~%*e4tnjjjW|D#cMdX?=T|K`rH z%rvw%*e1<7x!BgNCjGwJsHRKjbCTi({=~}&0Q1}8yGGpX`KCevL37Cj)A?0|`eV8r zRdyH-Nto>~DJr7f<9$}K1bYS7+nX(0abAHg-8o&JJb+e;Z}~Y&D`8YjC{AlJ&|$a^ zD6)8M0DH8`?=M=*f?u*`e`v#iim<8*QH}Q2t+2es8Ufz~y;GTN4>O?@Q`QfY1M8A& zS{Mh107K$zqYFhQYX`S0IB_6mL)SI1#}Rf9R!WMq;mcz|kZMoFm6;rQNNQI{$39`v zk|ks2wj#=5hi_Th_jLY4L@B&=`m^u&c;B8I_oAkw_jd*Kd*)L|D*9%AYp+G`r)uT1 zW#GsAhs+w@w|RoVW>OpsUchf4uP=XYX75LcY^Ef8$e52zB9OW|-n8E~tM3bA`qu8p z#0sDu)N)O5T#fweB_s zu^=55#s1k;jwKUxXI*Cu-r^icv>vYxP-n_ORMAVhf5%hfD8h`J66~)Z%zt$+mLC&jBAqKRRONn;vSP)Yzatmim;l7=jLesVD*0DN~#UMlpviZY>W)?K3A z#_}xtn@(l$<5ND>V^r`C4c{Cy%cBQHE>3eKnNWWB)JtTVOT~K8${|`_{T>DW_e)V< z<(xUln%C3EmG5$eQeFV{baKe~NQ?N5`B$PzwCu#dn3?(@vXRG}uh;AWzAef$!WRuo24o;xejpvlu?D5O611Y+E z;`&G{hx^FDr{PsUV|uTx+zIfSNlI~iPWHb1Z)HLn)y#;)y~6E( z|H|>q3D56!|E&c2OdY;=$6^YPHVLT-o07&h$M;qaP8cDMYcFoN&!#na!Z#~zd#?o| znsj|PD!J_N!vMR^Mpm%4qr;&ZUJPx9i12YKrg-+N{a9ns!JiA_5pHqR4LN(M52jgb zNb>kabZ#5V$n%jV3jAL1LWH@xODvm@c0T;ks|NZ4>SZDF-tKG~-@Oa;S4&>BloOvr z;{zCBf1?JJEo-(Tx{QHc*%kL>!01=~{PAcC=huGv+(N7fnZx){K&ldt*PgWg$0ILDRC2F`-UYv0-ySOQEOSEGR-lf+3#ItBJKL4`1C2thPyQ29#iQoaG zAaB0=y$MjCI@@rdp;;@lem2Ngz>+)@kR}bLILu;DJVF*4k4ANcBC1_a!r&f!_g$`6Qw&=;;vi$X?)QdAYrPrKv z0aIOiXfH2oTkx(B(sXH3vBwWd@j~f*IxE028_8lRtBJ1LZ;$YL0^4_1Br%kWp-G>K zQ!lzSNef%~7upIIl2%je{FQ*4y>hGm86w!+aB7l^YHa$()t&Yug+xFNpPc25N_Ld0 zt((#|)Z)%KFMPT$5zEK#M~Gq&t}t}g90%%496a?*WK~Lr-8ZKvP>UB`L{JzsR5_bXWN;(pQ3DRw$cN2?9h?r=E1>6-xaf)@Y21`pxx@n*vbh z(Qx(Z*;9LG&JMMFL^LB|nVeDXQpI!wxZe)N=%AP!F~aB9OxKf&C~W4lvy59}=)wD7 zI}j~90WDt!DZ2F7Qny(kP(7v}h`H$bLt3_}6{3~~P;lAB#IM;^-ZU@S*3J1&w2g0$ z+VT}be4PznwM0BZG`(h&LypNx95wM6o~z=>Z`i*O6Fn)pcfcqrBd%%uNElCiUAnra zT?6!Wb>(t$Sej)OCw|;9b;lMeU0KbovOdUvAFc2r%oIb(bYxgT|3=oH2V@lo_ha<- z7&P&h-$LieO3LIqu?<0(reU?MpVmhzc2j3qX!l9GdVg+pQ9$ z4K5$sT4g;1f7lv==FMIxn=)!aI>E4s!=g4uE(aXKhajq z9CD9p8;>VOVrgu^2S0`8pW39}rigx}3ivczQQq^t@4qYwn7x>~oXyOwuTh1o%1H@b z;ZavfDWT)Yb5+fhyK~)4^{Swy3(B|kLWjmmQrn~srcz5e;WY$-HQ!(kZiS zy;}BTIKA`tO5~y-aB|PVcEZeEkLB(ifuY!_(5&XRY$$Z&HmtpTj|=q;k9`t$CKeDu z5-?Aj-Du>_rGpiZ=du8&SAdxt29taYk6D4T%~ZjUp4CJg^=(i3N%9I;3yc(?MhG#C z_j?dc^{~2lIw5}htGFjY=I&gEk#3wO1&VC9%laB^?5U z?fvWXgE22f;;@l*9`c(FCJ3uz*|%cG+=8M;q2D5-_o=LkiFYiwE54i!cl$eRt(0Sz z-gbxT4ZmwE8PCKIU%<+(pE?N8)OgWhfjLdSlW@QrZ8BbTX_ch`_J`k_%(Gp-hCvba zi6<++LA~DDsZU}|kv>RMU3+R{FJALz7|Jk=)6pAC+etn8h(>xbb#e^zLwGC*n>kBg zH!u+S-Qr+p3jPkGc?-cTz6y_XY}~}j`};gLc^I~6?>H4`AR$v*6;3X_>4xS~U>xx5 z8KoX57oFk(l=IA0yXjb?NS4ivCWMbU`hC2FgFz!*CBV6yeZzzh+|wzd9@1gwM^C5H z^D#S1pn4Pee)_KclAk>5tdazk!SjBII?On55V`o&kZsDT&tL*y(+&y<7L$-FgWf55 znUk-eaZkAk3}YNB$A_fzn|5GU`85qzMo7M7?g(=hBdbCP_Xjq-HugqN=|@v&1_S*V z-XL2BbaP@N1|OM35k77gL;XaHTdN)twrQsOLUz<_!5Wrk9lcP1BuCfe!G?E5kIkrH z0e!fJAUqoHTu{-K#Xs-ZD{Po0VMUBX6i4t+c7p{&@J*?$m%P4&GHY=whqs-Br+19I zeajHrQIZc+gH|aD7enyx_D_}$oT+~pL7ui0ymXRBz`R4Oci8yFqM4L(GJDups3Y1V zXFNL2hCZ*(UGCJ>lWtb)e)3<|{^qwC=2gTnyx~&V&bhfVN|>~z*;Ta^7XHi>6<1lm zhN>l9F2#My>r51;M@pvhr@;Yvu3_8zm?7PL5n9cpDf%5Qm?yd6Ws(iXf&}aUNaay0RVQhdj*>WKoe5u9n% z=Twh%^#$%dl=rO)dyGv_N-Q+9gPF0N`W&_1`eFkEXLxwTZh>b2g6!)#NKCEV9Xphw z`sxmNO8guJog26^%5C3Uf6luD;m{W4-mYBEqY!r&#zvL=c-MgUzvWFHM4PgKi`E8l zSkP-iVK!B}*jkka5y*$D56!1Ky#t1xla6Ob^f#t1c+d4Vwp=#z2zR}!b?=2i6*;}U z1JZ$onk0q-N+`nbAkdZ!vsWo$3#%VWG8YR+TO%*VWU!d6gT+=| zJbWF}6bU@UqoitTejv#`3%P@+6AYo@vHAp|9H8<%59xyriKm%LvRipQB$$o7$H>6$ zwsuql5)0DYXLljLt$$7L`R1&lPH2w>I-sU4+1%jsnqobARfdW!ibIi0iXC$6(tBys zzLY>?=-j&{yB%RO##kXeXNE_4+#E5R{e$$vNgWD^GESYRo;O$|TExc~(8)A6uVBcq z3x}B)>ZRlCQBHcKk%nwA-y=sR`Mf-3a=nVL+JD`@`jNd>Ej&F~IY$}#b2oUkLfvis zR<~zKK(eqt{vH+ z75}HwQ}auitw!yYLpEHEW~#ALW99kCD{UY$QkM>+^-f`jy3#}?rPam+%xw*DSYqW6 z8xUd4c3OGYY5;LZG(z(8TJOp6!bPO;T!(s4FoHOWO z>WVfiQ<0(*ANA}5x0SRiM1A*%8`VBu{p3MLbw+=sw=__ex@c!Ba;>xq2Yv~GAyYpa zgDQB_g$gArn1geQVd|#2uYuqkp(q!d2)-cnA^R zJEhLql_MR2fvsdQa<7YV%!haSxe+h}$Wwl`G}R$yb$vjHVPFd~BUEV7IVwmIcfw*f zLkdvoSV>_d&fssAj)EmiUcf&|q!DH9bgt{${kqgcww2jBGBhE$0-!vaEcaFGxiqdh zlziDB4dV_wAtu5b{|a&SYpc48;!>3?uw+!+ir;GcjOkp?r&*m=(i^Q74mD~#P2w{n9*`5Mx$dOf(!bW zA`jV}$l6dnK{A|e*by%pl}O4gDY;x5aRQr+?>-VJPJ!tX)fcYJqXSj{T}Yj#Tbk*9 za01I9U5zKz-xB>q?7~*K$8`+Bm(@UyI5l(zZt{n@iH@_JO(P=|AZi|Gc@B1hTG#CD z+)l(zJ+c#XH{d*_nFtnEAg{sGYho%C^6(NdBPmGr?NgqUWi}n{D6U(RRl3VUHq+FM2~yz|ynE1-GX4;5Z@9o0 zqJL=u+*}2xh5}On)TuK^x^8}im!bC2Tu5Syu)sK%;@^+WLF->OYtyYdahY1o3Lio8 zQiul^8cut?1vd8&$AX~G3A&f=f&DmQ(3E4`H^VT`&)ZASD{JDo-^*=639b zF|<%yz6QdM8}zf(L50_hijAFnJ^wgt5pO`%oz>kh`kS^U%V zk6%*A7{6l9N7apjDb^1F?-p6z2+i&6jsczQ5S*8bFrM^-&BNYn7xnr2z%`*J7n|&x zBHHcXP)E-7hv5q@f+XskB(Z+-$b0LITBpf_ng^v&LceJC%)t?ZQ^z(BHAhHnJd$o9 zrl3P`vVg4iEd%v8yY5;v;EyWW@X0qJ+6BxMbtv z4v4n3+7W^-ma~Us_6eNW**4?X_79oZ=sQ;+ACP?v;h@zD1Z3=R!ulqxAeUp)^*m|A z9hVL4g9x)4H4c_px6qWHPDku}kvSD{u4nym#WAG+!rfh+xZ~~NRoSWPx8O#POel&v z${@N&+oc%+TKU*&^P2)9#$&HMkssn+dHa5oa2%yL0_TXgp0{tkQ_z@tn4w;;TivQ> zyy)FAS@AKtVY5=+rqE?Po{svIde=RuNqaVx6e+%)Ix!^YLH=&-_IA6Ikk4|D)mhjv zU>DLiYh9&ZpdvT(Dscx6YE#dKLa#e^f1W{u+ya){r=CFun_Ko`Bt&euoUX$y>cm%Z zBIy6|Mc`ft+ zT1*04_#i6`dFB6q_`CA!9vp{HttG*d~9WIRZ3(kPCx=raA8d zX>A;nH6WFMLhaK76Ry+`wO z8I0wGZKkBtMz~mhyoojGN7fDO-(_5{DoTeFN~ZA8LE!wmvE4d>U!YQAoQ8LYVY);H zg>{~uQ(s;tTZWFHa^Vv3nAsh|VD%m^^5T}l_RbosaFl$s8At=1u0vbB7#kxHuG2_yP@~bmm7?Gy+TqJ388Xc6U$A*1; ztfpSFGdf+&DrGOJuiE}Y)TbLSo9Z^Z9Dh*r_gC7R)h-gPOsPvdPCXZ@>^r|aWUG^m zKovu~nd|nAWw<~}h)EJ!CmIF&u$nXV1)S#>{3{2&OM9I#F3uvo=o@lbty4S3rDjj* z_TL@F5B#yX4ob9D?1?|i=@%PKQF1%1JXNO8*0o)^69yx52gY8aQeqhsMnn@HnUOd{ z{67)3v&O9!34K`7m zVi9GqmDWOa_E&&2x7i>UJ}~u8FsQ&%m1l^Rq0}9UxZw?6R=>EOV1ZlA%cVhC2Cnnxg_-ueks-x_uVR(8O$jvT5gYm7N+Yq? z(D4s(t5=z%;#!fid;v}eq;LJp?3`)}K^iTy9YOfwq6#n!-cvV5vYj<9c;|6ihd(`n zK+}31wVzm6uBv~wwgsZrk34VR-@%5`*==%blPUOc&9U@*GUW{p80(Z-(1M4DsuO|0 z!>SjWtgg%dsOHQ7z;(e;)@YiN7hw@(TB%`lzaTclyaZ80e4MBRwSzh7{f-6MPAg_HdWt(UU`k)XLtGwcQUA*0PS~M zFo=4Tf$LAIuo-eMri7hw+{|tT$#&w9psO;*fjrEiN`K#CV{tFOP=(P?{qyFO6PNambTGw62Wp)ChfMp#)xDjM3j*RWlfsxfIg+FQxYM0RKz88m*fH<}kr`jcq zDA9-&8-H&G9eH!As>6`<#9 zN5A^=p6(req zj+;&YA7?JJcBFh&daU-LUdO-uP4Mw=nh|n$d<9qT$J>+tiquTE{hP&jlUl$ey*X5R zOSRJ4Qk*FAL_f|6Xtt8X5yw)NBFkj=H$`Ln@v96^^tlvnTUiAcB zk;R)WL%Dv`@ErQ|NJcxkDLNqQNY3&@xBp&*jHkm$l%r~ie@!n5U_xh7D6U`H`421y zFZnMl@5S=$s!#9GHU^5Yrk<2Ddz~j`dD)XLxXmJjc*)iy#pX3W$;laB22sG~E| zl3>ps!>H;rqQ)??&EBz86LM(YpLfIXt8r}UBN+r$7n~KdqxwDl8N5bTP{*^N?mHt6 ztZh7XmKeePOR)QF>LsA=CJ5n3k+@?lvz$aB;DpF_{xZ^3+Cx0H(qqe`IK!aw zYGYgwKEdfGonj>^w5mj>WDTAm+%SJf=Ajqsxe57YPDeg$mS~i$I7S!9_SSyCaBxD> z0M17W3#P_tY)je2Bx8O%Kirc=w!y$v94=$BCmXZF7t>7A7$6WT#FUL_*IEc$;t3a1 zswGN&wM8!W6lzw2%lY-YluKKx7)dE@m91&=zk7m2&Ag2iJ}=zcsB++b(s01gE~d5i zHY%xu_sEz?S0#9RLy}5rk<&`OXu6|&W2?J}b;6W7r6mb14OTxOvqY6^LczYH-kV*R zI^3M!-tV8g{G1G24KyX$b~*itn=w6PZyFW`-xM@YQMR(JI8zQ;rKW+ZPn1#foM4g6 zrN5$}is`sW21Ms4FKuqv{RPmi!Q0v^DhH7i<7j^_we$|X4KHJNOS&F~uKS+oNf!{~ z(AJCsSUeI$nkw{AAVm*PFZV!9ll4fZGUV-;8JewW)9m?)9SITp(by##1~9yqutHZ! zs%K(iDAud2m_fex_QfeXy~U{32p5!)tf{zc1F+*%oVS;>e zle8zH42d4xw;uoT0nk2yTjkCOUUGuedU^F&ubl$s?TW<G8n`?e`Xp@n-(Qan4<^BQcY=4%<*=b){) z+@xocRYb))2}Mq%-G9_R226z868|QUY1tGCTb4;vzF`^$l^T9G{_#)(3xjZS1>ZNq zg=E5PkoZ{wPj%CA81Hv%YX5CfA1w@wH)nMWV+jrpHFVUzd{%g6gEX(nG(MVLh2Ok{ z=bSY0lV}08k}YC;INMZY@?ZCu06q20WEUNw{IQCaNQa)Jo@r^w-(lC$eKLK%@7pz5;-|mT^mlWN zk%C^QGHHbhg9>VhGP@^rI~u+oi5_yFpfBiQ=?yVx5^I9fm~Ob)zeq#y>FAGhu-rgyEUI$uYdCk zvmYm`&`(>aY+N$h*SX1wK>hYfS(Kqj(uS3qm4ScR{FBL{&{5N9{@3!J_Hs!3ITvo` zVv@M+(eXqly6iEFMOl{BCI%IzS1dMata%jR3W5<`^LU^_EsorMWgUtJeG7q9QksoRX&7eflahya2+X089i9a}szG^IhlD&vC8m40PzSD%S znT|{+ke}SNFwh#<*y@tncwufLWS@L2k#ToLi~F?0zYFJgTJ2x_}>aYivpJ5zKl@6&A)NjT^lnuvP*hh_Qkg_D$VYtfBVMb9^sU&esTNugd%rtyc)2;92RuNT02HT2_d@%xH>2 zZZ)Q8(z#L-4CJ7s1>t-p*VhX|k;>b(eW8$dyPX@RnbSl=nZtdp*lSV@21g0f9PekHb%DcN>R~e6J&54|S!LX{w47Q>&0wYK+@uV16wv3f%`(`CxSsgvN++nJo$>r^BIiegMPXp??>6 zO6fbjkJNHsBgxd3Xsg5U@p>`I_x?Wu{*!QaJrx1h;-Q|biQ)(#t>v8DzAsrdhzxmL zm#y6%+Wt?!1D*UY{a(8FKlMB0Ls`G7iZz%hIb{=;WgzCsVze&P-fEW#3=?N6T)i*lw>1bTDg zOHH38FRP|MtEYe3@awRzE|@7*GQX@kRbp7hu-qL?v0a2jwU%l4YD1w2H}LdH2;0OU zYZ>MJYsA_hCkS~E}PQ;MHNoori^X<_7AczY@{C~WAjMcMa4n+^cLs!YOGREz#% zl$wA=fw08Ia%Q&iUQB$<3Hmsc-`KL}?g?|YD?s^=ODSM0RkA^6En?_c#_rb;>+Erw zwft0X0++1+(e=u(_*!4rtnC$uYv=tSqkrhbLD{b9u+fi! zL0OP@B87U6_36@%9aX{J|AXnr)@j`+;rhE{bul)6I#UP&qv`ugL0q`tlJwLc7k7K(*iH4(x~{mB_GY2(jjNn&gn55B zEyI1(S+c?K2n7WKE(WEbX6Q(ZrDnody#oj+%n5y&dG2SuKm$v6lVu!WY$-;dhr6SL z{GlkPI)ffp__>x<`8K5?+-GdDxVF#F5s)PUx~Xd(dFww4~E~kSq)KbvFKUzq~bMaY-LNL@NOemtt z9X)r>Z=36wQ3G6uM|MIhg;piC;w4VzvTk`UJPZLtZoao|h@M^dc$9qSv4eJq#j3^6 zUs5=%`BsLi`dlFu^lTzdk?xbw`a@>Y@+Xt5xBKVFf;>*B<_}stpd{9K%W zK!TphiyBbLcq+!9W2h6s*KM%-{bfks z+54Uf-8r=SCnf&FEm_(9x5T<=Y1gm(@c7gc#6c&e%NgDxu+Gqyc5 z5HM`s%~JS*p341z&}>79YAb%ss31gcjK!6Zh2LXg>F61Wr|&%Nio{wHNka7O$+9^G zx-=4QUb-D?rmRn+s_vTwkai|~trfIuc3Phh1Wa9k?tTHT6DVIJWd*Nx;?%auDhV-9 znYJlHA1`j0-Zn!P-ag+-gU7#SQK9XA{g}N#Oa0_F-x)mr#qi;vN_CZU%1GxY{Yavr zg`kq%^!i$dkW)P|Rlbn4exfzbCwHnX1gVRQDIhE9eHYN zZ1;97UANb38PqRWI?8 zT!zIK}h&UM|Ue<0=dq%lg;G^fz zQ$zVC%IyZ8Z_EW*aR3F*ffY>+E+?CwMa(qms!8xd@3@qKkQ*l576Z8OOM?ka%{I*+ zoQ3rYg?W~*3Up!wd>&xJv3oyKHjwci-3JsZsSpK)W2H%JCB$7IIK3*Lh9A)(?+4@` zmi{08DyGf&R4aCJFHj&J?swoU2ujO$@5{AGsKc9{Pxe^@nKG#F#<8zh4(&PE zm_;5}9mmm+kL^5&kf#Y=Z70pV^6>0s(oKcQKT+2kKdd2q-{z>~o;51=1oT$tQP7%k zk>wGbSN`;*;w?(Ixyv${xf=^>wD-cWUqMmozS_#Viwn0@!9y`iH!j)unqAfBsskZ5Kd-@}#l`X+bT=EoQN*`u@VmBaon%V9V}Y2jKz-l%Ea=8wMn z!j(h-?Wox~mX|71gc*ni0C0MOoavL8XY1m_Vr&>sIMNjB1Sg08aH%~#My-SRq)>`R z4bZ5a{U#((@{hgYAWWfLVJA6B1dVFgU%36zeyYJCjS)Z$wr|n38mnRi&VhA(_YR|n zJh>-<+xa$807~SH(6^?^;=#$^Q@-;0RW=tUnXNXO-!!RN$~LVhXlNZk_j3q#l}gviP~*jR+nwtwr$(CZJS-TZQHhO+jiCK{|zqU zj&g8LBjY=J?PWs})<7WoQ%KF3z4ydWl}(y$%YM;yi(3USBGJdxWoZv;uSUtv#ZH2JA=MYO7ilp4qkMkzRd44o%gH~PF)HG92&I$jRALOAK$1#hk zZI+ZD?&YueYNpi}ednr?K2yUIu;B(W5`ym%N`>k ze3M+8vSdZ6dP*rvG?KufDJ?CT_3C$}inHo3UYU9)s%+N|7?LN06wAE_0aO)axG`#CH&mp^}T^|9+D< z1a9NL1*2z|kx3Na#Z|u?9-GUH=A$L+O6aDxbA*Lu*Cj41-=#Y7d5UE!Cv0-RLOY{ySht#S(#_* z`e9G?ddN-b=)$$D%t<=|?=cte32L)NH0F~50aKous7LECYd=_;M_XzVI~Y4?K5n4{ z+NhgMPYF;+8lv7 z6V#b@XY;SP^oetdX@GiOapKClyfEzMFi#n6a-N3~mAeV>ydIV-y`yeaif$oGn1XKW z%a)R;lO@7B%jeXVlPI3GM@}@LmX&g3?XGX(>DJy*WrH&Zp)RY;{f^t)E5s^G(guyk4Z)_WT|<2VuaXrTI|v-DWSQ*Q0kz)lDn zWE!!Uao*`c1C8 zjZTIQkW`&ht$X%Jx}DlbwIS23$bhrh7cDuB?^~vARSQZ+Q4SHlIyR^n@)?&!pJl8% zl!Y*F&qSR<7=eMhxz&*(e1jJAtAZR@^AKU3@Mb%;i~fLtK)8iK$U@6@mjbkWFuqw0 zbMCX}e;p6i);o#@c(SIq`kg3~X@V%=41 znzFKz5YeB`VX4tbjZkA@y%CG^k6o^*cvY~EGB~}M7uW2FSIL~ocdjlbYpmS*(yP+? z`Ue@XYz%J7tQT9P9s}jTb8cNIPnTu@ojMMj9YD&l-h}IM7ahQ#g>Nf!R+({E5gV01 zBOtghSz0d_X0iNa$>5~5pkf8dz@QePn=#o!r^LszKCm~81}sL;qx(MfEs-kQq?@Kw z??~Y$ci03m%bHl#NG?NPKU#~%tb#5QX5PlnV~{z>`YTDu-Teg*d(V88+r9EWdYb+Z zWl(Cjk+!Rbe)A`Y04J-7t2?z+H!Ds7EpZt>s2TFne!gC|fJ)^{SR`t#+j{vO8EMhr zxT%nN4uj++;qB(ysiW&L=Wp^s&{>5^thiPU;xD`6szg6mTIjBDGkp(Hl@5P>eg%o932k2=0dK4 zs@`#((9w<;!?+KEbd||T(V{~^!t-D>$-#5$Lm8aHqV;;b+c6S_X+8T4JEVvb1lNPG6%DPgFsYwu(P(T zJv~zg=76XyTr;iYzAO%|Be+I`^nYeGq-oicW{TUZs2~4Aq=S=W$dUfKHF0@y_h4y5 zAl67?^lwUO3S0%T_X9b{F74o zrqefazLz7B@kP)u&G>v|+l`M-Mgt+vjtEh{;F~2*4p1hNBxb^l4JaMhMW&&NG&f%brPYYGb;Y+=ck37U>$)?Ty~*Hn;Ese2V1;n|9i&EBRU z`n}F09kki%4byY9^z89zqG}hvZ8apd?Mm=!&!QfFCc(VkCc~g1hlks>#ic;IJ^3%Q z8Q%8Xe@9pUaJHm|oRIj0bcr_1tCHlah{~EXr>?(c1;f*UVSTz(cT9PnYYm$R0%{Y( zp+lLmJ1n;vE9$9h41NhHopR1l`jFika=O$U7SFg;lsh3Vp_G)+q0IBjOGe4gZ!B@p zHAV-oW?c`k_EOFeUA}o3v){|I#8n}k#=8*5RUPu#sI73}p!!0STH2mu0lJ203BdpR zXWb9CZP<|Kr%p0UpcQ{erx7O`89I5$)+2}kM>9&Jd-sw|dvf(j*j2}nGNI*EPzV(x z{}3K;VcdW6jdw@!scZ5Lh$tpkdq2_TaMe?(sDAM8u||A!R>M_DB2jvDkSMMpQTL@E zAR_ZaR48%!lIEPA{oF`394xMSJK~Z`1dtqSS8)@BrTm-4)vOeE0q2pJ z68Td~j&(R3IpfC~@6w_b&`i`|A^sFexK&}8vS7o}u#u?2T5XC+2D+srvjv?r6jyqm z?kDAQ3sVo%Al(3`86{f_O+XXjc=oS z-SPQDv)t1sqBFu)M%5d+F9=-qQeroWmDa)Jp)GjA{XUAd4~zsyGY`M$q&1eI$Pw&9 zuf+tm>QIHss~Ed@z8>Z%Teuwvr$(_NHwwleJ2*b&e0Qg;GdOeI`OJ(H3q~S^@N<_0 zjL{+TV`PzB4$(^kkoPxWMv79k52pD`R0em$(&UvB7qL-8aaKgPQ)(p`(s*SWIoJh} z>Q`BdzDo1ayt{Yw8Fym>w}mPz1qJeJRkTpYy28~MObYxE{;+m%8kg9KlZbf#d$R)#a5UEcRPuONlD%G>fd8v10^}H zStJ26CqGLiD3bpvQW!3-4mwDXB>yTh{^g4DqJ1F*BPmE88fEa1Uw&Y~ri*VSPxs-B zaPsG8|M*v+0KqryKM-b7hZL(|`nyN%rzMSMBHz#B6Tgn8aFnRFE~n_f4UhMe1K?!ezj~FsazEG{!LLa>_!W-mx%cAjL9~3vw`|$RRNwl0QiqwPOA_2!>sksNvgKUA&83WJ^EQCgw`stJkChvtExm2DoW9D?HN0K2n~pc4LXUU8CYu z&p_AxQ?e-FjelRFnh{J_`45q_ZzX{2&A)t*I)!7CW~Jl#Ra!n;3wBp)S>4(+DoMPj zyenTNdo+N6l@hnQ#G|A(xD(Ic0|et`G`+UW1Kn`d>wr5w#Ko>}o^$V2Xf7yBlL77E ziB7Qt*WD@UV;2pEU1`Tz%7CfwSA;$ITN~T=wl2V2^;erKl6h{OjMsA32GPEV#b{qC zxyi`QbuR;AIqnbEKdMM^N;cc(k+d@R}bG z*A0B`eQG2g>$#t%ULNEl7J8ev$xkMJ1y^*RiL$^^q<4Vt`Y)%zh=W_ifzb7Phs1Pq zb9^+mwn!rb8@UJ#P6IMzoJ=QD}(g~H`Z>0+&Psa~$!C|B{{P5ygfs?pi| z-zK(&*B|_g?cSJzCkhv8+=u_#-s^FZwt2yxH6e1X5DCG7wZE6V!Ia9S+0o~-s?8Sa zlwei&=W#C3@SpJb9t&E(Q0UYP=%YZ@6C1b;m94v!PbrIiqH<8-vpN|ll}-|9Wr@sS!GJsal+aDX;AoJ z+d3aMGYtIoK5e*2b_QPUtsBBTSs=K)hx-~hAgD>qwTkTEuBO803lWFa^X}3@l~(%1 z0QcL+Z)UMZJMB&Z^T$%a>2H*XN3*5E)8t0)@%=mX)y~Bl?Bwb@HqCRfR6|Wk+&h8KY06o`DtsStbjz{Gz z0^kP1Qg`x9YMdcpf%wv=wz4COMHtO5ki)xm_}#`)tuN*CW%BoRk)OL`UG2o#0&*>V z%;k4N3$HBRq8*>$=w`;U!flGnb3FZT9c&eWgUKKV>*5QmG&6VLJo zEpm`yI~T8m{zjgepHXLzno9pO8gLA*41uw+yPCGc6UXomffYb@POwMwe85_q*|o-N zkrnkUvXS6+?Cr3jdXFS^|L>*LMaj#={K>6J`kVecF5;@%8Y$hKC++edk!am=q<_zl zZ52HGTT}>ZE^cB`Sb8q+om@XUKnrRnhx@C0pAzZw1hD4hQnuFTE_3w_p!gXRow{xs z%tUaSJ;IlPLVzR?lw>PVJsRNoU$Dlam2Z!tZ(HtnqW{E#r>{H<=-T-(|JVFj0-UZ@DKW#URSQGTfJDk}S zd9E5&CCKGz_PzwK(Iun_EOHiwFbO@m5P?cq7!89!CEu>|2r#fyrTT1D(DagS-}vQq z*HBG{VrakZs2GRkYsr(BMB}bEv4!fksI?6MBCV*qh!KD8@A|NMu?&>#I|cbnRMkaeBJ zD_e4=fME@h(|%z0;Zq)2D}&>~COK_u0L5t02=o(YnsroGarVcBZKi`ltz0P)J^Dd! zz?1O0!W0MRInkyexkGAXucjQ~2&-)<_F$EvRmG%LvTPQe6{EEwcJH;--jiO#!FDuW z$IA<9-uq1(&nrkbl);yv@?(lIwq)xn4AH8T87LlbDrF!JFLiw8uOFq-4m`wu+SX?K z$EN+KQRDJ-(X&5C68ZKUe<|{u$``qC^y~9p1kfOg4bJ|g7&s*qLLkylOGqI27il{^ zs>4zUvQa&*oLBMhvO|JJLAGRlYkR*6knTKCoAk(YbFp|jm!{nvx#*Q{?X(WmlZ%;U z$IVM?AgP}s~SJJpw1n} zuwe;Ru5~vXo_G8Y2IV_{v@&Hk&}4yyBS1v?z3nrm5U+Dg3#TDkgm72$s*fZR7O}$& zAXbqf0%;ZSf-QB>@h4*%g0CFQ^dAkyQfh+_%n6XLZGRF^E5zFABC)tbxYSF$6^w=5 z0Fp9Ii>hV_#R*6&?*-Ud@ACjM`3yi8CWQ#=ux)LVZc>`se=Qdl93d<|GzSkL36AIk zX2_g7L*L0I?p#Vz4IqHL@x5KsL-*rL5@I?$#*R94bfIJzMPyGc!JY|tTlBff1``|= zttem)_H-hN3VyLhTOvf8(xUO3K)Py&o{b07$G?3Jq|dq@%4qZ9f@X#thTX|P)go+I zBN)tr%+`gZ(>jo{DurYBYUvzZ!xxrI+z69a`nfxL@VELcDb_k*+dhDT{BR4FLSbMT z5g9YT1Cx4Iz2okh1hXPGL8%R!wQg|5X@A@Kpa%49yjDxksQz#@7_QF`05VHb@Orq>2 z=mkygozC&K@=B*KO6BIF$MP2T1-L%rA{q!V(vi$n9@&p#2bZ)xE#JhFGhW<3pRFWE zE+9ncQsHHIgBa!VbP{4c?XLW9mWwf(y^2T0>Mo)&yyl&<@CQssJJx-8GO&K&Uey!E zSfs|e;|R^MK|2oeiU8&-aOX-Eg4Kt6&qdqN3;XTgH4{xI*(cJNDiz#cm{@5MDskwa z?1X`idZT`Vf&Oh6D}_7f#G(wuEHf?iaz`-5B|qPr3qIC z!@r^N_Dq>&7a@r53#e+{d+c6Vpu)A?(Q|32wRaS$^s1p zv#`6_@!?Mc5$McY%7a0VU*w#JT-n<sR*ghj+H`Zw>d`|q7A>+x-8c+FfvGahibEK*zK z$b?JDZ&vn{o|@uf)wbYg)sOdI-wJxDJ?1Z&+lBiI zy}`G`R0?XK`(8pQp|_nY`pTbXOnnK$$@3wNkE_|Pk5g9z>zi(3-+T?7?%shqU-bSi z0KawwxN@^}`U3oF9XuaFbYAr9^ys0Fej*=4;OksJ?hwDeRpA0?zef1LZ+7m!^A{iD zhi6n%M6@OS4~jKpM&e?41__=kY4#Yeaa0F)Rqrna1iylKaI>G=tv+vDZ*yH`;c;T$ zD;i9-{fEcS!GAnJ5oa^Rx?k6u+}AGMu-3beFHkh7w=-v)8RAMDm?zF;dl#{sH^91Z z2}|GO72b7y-$S)pnxq$Yi%5AT(? zwl5-VN;&T#NlOtMQ_Q-MbNbots|b%Zn`3{|yIC@A;q}vOLFgv5x>M%Sa`3)0*C~<$ zJ)!w$v$KFheEC6MI;kzEcMN2fJWmHRiV$|U#Jj!{=ABVS=cpYG1$;o&!Jq z?R7Hn<5-6wx9pZfX#BHAd;M37(c;OB%Prm5Uq*kxx^>no@3oujLk-g%#h)q|7rb!T z8uyzHS#4fzZiHCY2^n0cS!P3@9CbC{eG^R$5wSe1ELH)_nQNxf^`v&%I;xGq0tvrF z5)7E4bE{EotFu(JgsYYdXrK#lW4^Jm@Q{G9&7gN3OFIiLmbkDoK{DYfUf@j`>7q*; zVEUSq763EJ58o7gr)Ck*l1xir;);JHxQ3(D7c7JD&I7%s&w!iFuS?bn79{pQf+!Sox=p zKibsDtE(bW7>X;|_{^B(D27)iPK6NX%2{&YiC1&*5qbtw&zYoW>V%CUt&u>pO+U(C z0ZZ0wQf?JUTA4?F*F9K&F;F=H@RB%ar=>DsY=+}cfK`bx5~Oo++!!N9VIM{|jj~yy z0lw^k{L~HVJWcqk?j`@z;636Fz%=0ROCN?7@*ll|&Ex7fZ0Qt&NPxWbe?&`>!TK(x zjDQCBYT{mXUy{_~Tv^(aTuEvegeS+Bcr6SZ14OO8D;|e77($;Wf@4OfzAd@9A!p|9 z2n$1(C;=BZa1q%+M3aoEv>0R>dK=2D=^KiAD$L*&CAkWWYDLnB{<*4Pd0iFhUr^P8 z2n$BN%@xc9rbF%O)@c+Lcxqsn0kKL{-5S7uW;m)ur#T}mw({dsl5IB!a~i7RaM_-A zWz(5RU||cIlnzILFG`?72gc0pWkuxvmCo^2zJt$g9MA>T<^)KN@@$-CW1HR`&jrN} zXhug`O`d#_znU!(#6g;x)g9R+m`Us$XCA27QO=IYb&f$a01plbd8&eWu*H#{Mb>!zmEQ~U$GsWQU3L4mAAK5j^ks_@5<)pWl?HHZBoKCfubKpa7Kg8I z4X-b6gF$^ft2D>O2WW!Z6%6uOmtVX*KXlXKKq7I3N?9gO??O9%ahCW5oxAaV2`OSd z=W1BS9C&9tn{Vjf>EK8Cl^wiJx6ee~I_19y;SGrdh*w28gb-4wC@*oNJkU_Pd!5zU^^s#6aEx*gkOS0nlWe9@gJ^b9$v69(L6Ct zb#tSKi}J8X`>{ifL8#t}?;(FS7|xJaUMElU)g&wqBK3_*WTyEweZ6DMn(9&4sZ8_l z5stbnDxA_k+27`l&S&jTn?_q@!cDxI)j|N^$&mMV@DJ_k6POGQdS~-@Vu6g;H&Oul zA&5-{fa-vG5rUUFXc!{XFNVmL9?*~WO#sO~K}Jf)Cr%66+_NgzJ*Rx5Ck^cdE5)eX;3R)gCJK8(iW0DhL+#1H9MOPtCD3E<$K{pvs9fWLQS1`_pc&Vnb& zy!9J>bDad@lhByp|~k>|p-Bl{p7{qfXnxpSRuX*3@y#hzp!&Ns5@D|C<&Hu6U^` zRK$kgDNwHiBDI&9d*54KO^~Wz_ZBKl=Acs&0_EU8JMuWYq@k&){_Irl3$Jns;S)CL zsPw#hx9R%5*AksPeuP0JCUE7i3YQSPqgud7qfsS^la`KfbjwyH7c9BB^4A%n=CD?8?jB8TNT#qjsdWoBo;qtgX$r>rpf z%y#AcrAnqf*K3vL{E*X&<9p8R)D^Juwg$SgZt zm)f;@VXfMef5SA5#?JlUQ)dXYUf=lE=R}*xXDm?Z`a^6bYBtTYaY7_M!m_h?n8w4v zP>oj4_v#HV#wlF$G>*kL9cU)y-}d$1FoTkqX>bfGxseR3DwI;EDm}sOa$SNNRaph@ zc?ZL=Yw;V914CTelt+q98cVB4whm%l<5AT;5@0+Kalm=;^W^Ff*XSET!dBqWix+#WQ zatZ?({v#K#qqvl^>h;FZ>xy|LBSaa;&}&{Ht*)3-Y0-^#!kMF>0BSQ%qOGC?>S~LX+NR4~=ufgiU2Aqz^k=(hOjD5<*CPc4US%i- zaCkH*w4XMF!|W$_i|*E=-Tl{wgIhf5EDV}2o-R;TXqj$x>hf5^YZ3v>9DD_hw^|IM zs>=(0L=CR>nb|*fDtEfJL!S;`W${&Zsq<%|k-SMr`u9T!^6DjYBpAcxe0S@_p&u2p zx^c9_5Ph`qo%t#78FN@N&?ax4@qv5$w#&!TS?6xlP`#TIVi+f6Pt{apt%t;osECg zAJ3IS{nlG3|4a~vT+QK<9gW)?DdNLMYGT!L7Mv)19%`2BXQ;$azIiug%_@i#>8{6$ zy3*hZZ_bmP@x$(10T|y1mYTc+C!@vi1YSu_uAp-E?5Q6WZ)T&4#v6-K1+EX+$_cnC3pq!|0YVFV=>>UYP}I--BG)Tmm){HV+m9}SoLAe0$)V;F?;mm`!R5J3r%!Emx7#^X*Q@W@4%{r1v!2o&P)-VJ^)mdjswkGC^ipVE zTK}?wkK+`z5hZ9J`MlVQ@pSs{{T=CI4R};O@!V$byjpEaxt4!9o4l^_R zuQn?yJQQG3AAjjXp0{h9EG=XB`Fb&Q;G3}9pG}Vv@z3ab=bwpqZ&HNn;xdtJQc(ofs|w+c2Y3`|V1E$H?7$S9N?C6>H?9WAz*~2W)%%7;%upAuSW$y7EDZ{m`%fx_ zeZC6S5VY2-)MG3YZ0`UPo2qYz0fg{mi_$ftV6JU?Pdg}g5hVQImH>cgx8lqRnD(!; zIUw5*MQP@H_M$thUpCnLJLGDa%ScL)KD71YV4(s2}BHhur;}mLKJ7okv+~--7 z_+$k!ZOn3mYkXq4#~>r-Ge=_DQ@J+vMWHh(GW(UQmfgF{tQXi!{aZ?yDXdu#dCCfH z+1eHR21Q#?c@ecz^|t^6MYoI`=;9AMJaW(sjeCBIoYv$Wz8unr$K`*oMt%YgF=>bq z9(nG74Sk2G3NLI8A|G6mg6RMQmvx$`)GXNS1pkF=Rth({9k`=Ks0;Lis3h(NuK*PP zcpiG-v$3WWg;m`sLgOf7d;>Dd?rP@=}D)0Tai)x^$*y zTRfd&1^@Gt0f{Vxzr9?R6T<-S;jWU8+(5B$?^2L-Y1|5rJ{WAr*omC{heK@_4xwgB z5b}x@3rV$rgq(>+9+EU6XQ3h^=9|!38T_xWtszKnM%a_0ym@!Az+*rEISKGw&kCr} ztuk@Kw4NwgnWfQaRVg;``OX|vBVMK1NRcIJ`~>g86gN}2vuDtg1SRKfMT+Feyubvv zKdLyhfD41JZo|tlp*9EB2O<^ESE(e>+DMo#x5SWc3X!PV7Hjw-PKr8}Go1R4C7v*+ z^X)h|fyHI*MNr+qt?D~|)>=Io-Vm@4e5V|5_$Y*>_k+L}j1PPqN@g}MM0p~3=b z4bu735!c&JPY|JjXxuf|*ua|h`&8$vM?Hd3Jhuf&$Pit zi(d$PFDS|6VL}FC`e306hxXIgSP?ePBK2bK$s3>489;a8O&j6vX}!3#Rct509AkQp zRnf%oP_5{%53q%`Fk zZW6M}0Tt}kaO|dl0$b9^Axv3ZCqj8V^5W6!ubT?MlY-GK2<_|8T?ju^sT$&|^8*ZL zfa;v_s_`iqo0YrJpEQ;R97T~p!;heZJm~~tBF}F&U^PX3*qgzX#R$b$r6*yFPnfb} z8!4(%NV=o9g7nnz_ZnFGKCcKZy+tfmeI<$(YZCQOf~i>6^rk3FDSd7yDgC!}b3^Am zZ$VfpW_P4rjoFuMiBSy6-K1F=&ZDs;;Dv)>`92KcaD)gqfkWF$TgKLY9rnnY0{Z)Q zir2tVZtgmmd$Vpc@RczsQaviJkT7NR6A}vEDauXRRGZn7Uk%>`>@=%>ETjR=`wWvcK|w`WUw?&X$3-@RoV>K^;Vdo9jk)!jk-^K#bgqR1$5>JST6?NwH8}ok)6U z8hzodET!WQh&UQODa=w}_=x=Cw#$m=AHv&j7xJG!E6-llx??=*HBoC;9<5s_!{4z_ zON5Ldr;RyT1Hx!vcH7>{7*;j_Ml@MMkNVf*Tu;7Xcr1!q!_?-v$p-nvxqB*4zErgu-Z9S@G zG{oN4h4yUo3sU=tkgQ8%u1W9<#nS~`7Dl^O`P@#dqdFAx3w`uX5Ux*J)Ng#Ani@*h zYpa-hi^oOFnQ_}Ddw6@i{+Xcnd#Y>Wy4RaJl)s-||C%lC%1J24vMC;{(ZgEyAnadG zM_ZYXpQ;&sJ!Ql@P|;O&k(9U!k1;9&;+03y$u{!x9$d%DfVniGTkyTM-_ z-oN={&-1N(fVrm+Vqyir%|E-0H?qk0vq2M# zSv!f|J=~dTjRo2u3uh6}lnxMQerPJgM(u7a3&)|q!%6s~{l z?FZIvcFbCuhm{eT3o9rA(eWP_H6oSz9jsXw3bxi--^hMAh*?jmAVq*Bh-^fdM&Ut< z_#Spsmy+WQF0Wwa$EOIhALkhpO6tKs#6$}1sn3;PRg(j`?i?;EvCH&qYb=O7rH!~= zWFwds^+Pk9`J-1Cl(1-<8WcI(-@e(09O-DE-S4I*HD*1C^J(_Ux9eHYSrW1d%IGdx zU9%4fgIl^Ei2RujD%ddl-BDAJ^$BJ(oIO%Q@LWv*s<>~6M;<(!dpcF?AkuVAi!bIv ztSNGc!k~Ruy~F4Zxlp4#f8+&_@JyW=o;;b*#lDYw$fAW9fsiLu`oZg?Jva$!kDa#t z7F?P5;iZh)Cxo7og=jE;ZAqL2_psLY9Ddp;M{30-_IjbEku{z_3c2#=+!Bc`=sa#w z?7;qp0u}6eKz-D-$hZv9Q#4|YlOIJ$j@z!7EBPdc!sI)4|4r>U74006{fO+8wt}F} z23ncxYYwH?yRx8Kq?|aJGpCI>>5RLjIzYd~<Bm-CIxLEbS~h=la-ajoAzJ$XX&}c8;|7- z-cMUmhJ*Uiv7r>LP7ig`%3$LpqaxT|``}^eL1XFA+%GkkM2kN(saoO58*n2}t>rB4 zibvP1spUAHDI=P$IUC8z-bj^NSZnHc{eTaeHml7pxoTFj`FDx?B3s!w@2+lURxdrF z7%_B``Y8Kh;Ng(*wd>n(THHJ@1+C_3_1)Ounr?krGjGof%Pm}IM77(?z4K)4&toNe z?tvvlD-}J`ZCv8xIa8ILJlIRVFRbWUh118J)EX^TdUml&Yrv6P{@%t&6UGg3m^~fn z*zDdQBP8HHzdP;`mM!roBrqdlh|n0>uozI^xMPkmThA%1M+KzBv|SUb3Oe4&z8KGB;ism9_PHm&=%<4P*$J#7Wh^ z-^-elWyf8Z>d@=V(H<*goWR{yeZR&$)thNHfw5%eXdPOqfxhr55U)pRfA4NFpABqO;wO?mK_;Hntn?4iu}k(rPQVY>P# zYp{w(9Hk0-wO`+^7vZb;B5M5M;Z`%$IZdw9<}oiPFJ_5TD5xWb!EvcnK8opSjz%@__9I1!V?1&()PD$+28pSm1 zs&dg4a40j40JP0*p?_8h`5{+5_EUM5LZf5XH={AMr5WDVWc4E2Sy_0`@I>iWJE>2- zTJ&J8lo}^J@LecWosJMuqSPC>Dw9GjoQg78q%@+MM#CvtgL@|qotb2ct*I%PcPxPB z7)F2X0xMxA)$;=OB@yD^>>ZMlrC~~Zv9LHp3r$rwg+I+N11bkt47T6|uHT;-gv^o2 zka@;Hc|$}O0|8sBLZ8ip7q!v>ofjq+@Tv02&!eviQCcNL=aDxz%6!4JU{f@oX#{O+wEz~izlmIr==#5PQ)0Al~AFe=N zZ|S%-`y5t}R{z*flzt9I(RU!6mRrfIOz`BgbnY3`-=3B&@l`|3Vj;Sk1Tb|>KOR$ORl2z;a0^XaMa%gO^hLt zKZBw@E`?Nkv8rJ)CO#AOI>CKvS&r7L5b~U(njaerpGZ9Y=P3A2A{X1p2ESv|9k=PC zTTZ_99u5vK;G(lf;rctXUbB81IVU&GWUo0dM;{)0D|~_Ha-S~l|4b~quCBQd(*I;B zm)nszj6B8T24bpg0knxSj9CgsdeJ2-;}@V+lP*PHc%B>(0r@+Cl^J4dacN32aX>rt zUV2Jg=Ai<$Q85-;63tn+j0?!>*=m#}I{K*WK9j?5&Le{;n zT8e@@Cc%gi{`=V_TFL~a8jl}^MH09t>(;JBi>~9Hu_cWb$%+6E9As9gu(QKqY&Z{z z`j=Z0J90-!5)xCrZhK#=(`!rdoM}wZXD9pbP|)H16RgKW%~Ief>&Ci4-->EZ@yDS@-<+L;G?WKOi^s+fSUVolVcvle!Awww9liFLq2~Iae`NPq`=J|HjE0L# zcBJoZD>7L}pgHe3xqHQ{qA6V*uZYzXW+%Oy?wuaES08P2KA1Ebosp=JR54mCdLg-} z-!~eZ4=S8r+ZLNOVSG+Z=|o=m*9Y!m^7R}&b&lbwOu{C8%LCpX9jOFm4E|{cvHIu4 zkzO&+9A<_l1SSYF(ItsQX9XCbF}9f)jAKS>EMg5vLKAeELYWPn+0+cm=GKdoH7bs# z{isEb$A1Q4$raE|n7D88y48BJlrA>c^W)Bz&B8%LTT01X0Cy8d&4y0_aq(g}2TBF^ zB9qih5w(Ijh3k6U9JZJ4Dz*6r5!nj9_?Oh<6O}52tURMMYdXiah1`Qor9g!K74(!_ zF#`uDxDuc|;@NBvAl;<{SO3uhj~w1;naHA z5T|zSB#B7qx?I3k7E^5#|COSteTw6SfP65e0r~RC+!a82M?sW0uaETcxosg<9b;=g@5aRFR!Wuco zWh0NbMFg6CD&_Pz#6DPFL$?LM8pH%-6#YTsblA0SPL@8hyRK$?h}-Je{ovqfVkavC z%1%)s!3v&n86w zeg?ua)Zr8bwcEj%F>QdbGhM=d3lU_dsW!^l+Q?ACj_BssVb^acn4 z^Ztv?ewQ*6X*y^i-}(0I%?|o!ZE=f|b-LWpV==2K!?y|T1pEehJQYhOHa$6;(@*TI=&fWmV+YSBCY< zt@F|b)*(IcH7N^+!0RNAyC0G!^`=tgIhX@QQcgzpo*Oyw<;A?&$8{WDH7XnqH~CZ|LHX$KN6 zm-PP05m|sz8o$At&lcM*8R+`#VP{p}JX<0ZZ@TDjwrEaX6=PYm-lo$l4Aca-Df0PWw0IpQ_|+EVSa+ zrM8)9vn?(?V4r0^+ilD&hZRW6&2Y?9&b!K-qLKb2d@2D+*}9|oS8wH8h<|OZdf7Dn zs=A{WrJ-a*^Y5Q};&G$x2|dHsQ*Dgjc@q`xRIe>eC3fEGr*-AF^cMTYz_`ApoXDG+R^c5jmPe|w%w2H<~af$DCW}Q^4tmJZ*!Kp8pPcElm z0X2NNNk;7$)eDkCB2^lk33B?8k}FByb(6mm78~_tK7B2y(0x~DMWzoVMl7W&Ueu&i zU?mDkB=s!%I}}}H&eycWI2)Lo1yLG`3rR4Om7PHjpdinNpLckMavdOB)ZVVYnL_X^ z$S;|CMiYEp4&Qd%Qhh_uw1OZt7jExE@DO%Sg7E^ZxJ&M=$ky~I{)tLcQA4PLb47Uk z#P&~*Lq98tccTIm~=>5rw7iJB5b1*#IZWtOK5xw$GCC{s;sv~ z4KFLOmUFGQbEj6GAMx{cQeWX;685b#S?y4F?<|4oR+qrI37PdYxrMRBM_Lt`ZFPmqwAA*-x)azip}33s%bKHvW}&wJ|4`~IS2 zh_>ffn$(Z!saXK@A};|z_mtb{pQbNC$P?gGe>9mJ^ zy|z?tJ~e-qxw25uw^+pZ$y{Rol!$7rCFZoJX7xHb&Q2eBj=f5a@msO_`%6b`I0$OR|`SiKRxvZm3ru*_3XYo3&qWqQ1UG_FvaDyysRP z+>k^4va63{Zm9SgQjdN>(i9RRz+L50g2lP}U`%3A;R9aRv{fzb4 z^4U;s#@KD3vc4ww*3x_ty(IUVVV`}co_D__W4)hBlb3zWyQW}qrGM}f9Tr7ue2o+9 zZW6!PF|a+jsWHkJ8qE^lT59B0S-Z2z<`@_6`274ozRoE~lc?R&#jkAJwr$&8wry8+ z*|u$~%Qm}g+qP@^KXY+rPE5?j-WM4ekr8j~y&`wMxt{g=*VDpv)6(;?tf~9I$7f6k z7+t*8QIo2#jm3NxQEC{y%(dj=bgm&YA8m^O z4QH8&`4oSK6P!syv0W*gf&NvPdkpxdA>u#Q11Czjy~QEoul0Qxw7!$lOK&^Bhe)@X z24$}a_u%RfNA!`9X%wH+R7UPUyyngaR~aaN0jBr3;wz}avwChENk-ELKVj;>;SruA zr16ABRFc`HWWq5IDW6@a6SY@S%KUY4RCy@?2QVDdCcO511Jivb|Jf%)y)D{Lz<0vU zyNbo=C>c0!o-+h2wlg;^DG|5Uv4ZxS2*1EhY|tKVp@VI8uLUX{b#CtCqCgr}a?4`e z^XOiL`(cAC)1k|XnIFYIB&1qFulNJfGL|R6?9J=;y%EDzKQpQfF8@)JCuEZs#r6}s z-z?y2JrZkh1q>>BbkEgr-g_eB{<&s!?rS6KF5*P>oDy`D?;3y-?-?pyHHwUx|in=4+Z^Zd9MR)Mg%-~UPiY)ck(*PcnsyXhc^g| zek`iH{5SM@x1zjt1^G|Ao=f_41;+mZ{rSa^kLHe_uPc~gHLsq2&&B{qfUL0||Gnyk zSs-zmHRt6~R=!vU8wSQMNtR^tNu_-V_Xf*d3X*;v-5EBp?=6gV@HbLYTCpjTMK@8B z*3vbuLnrk-&r*Q#@1DhLChMKeZ8W{-VsBh-#!*0aj11u+=b4%GxggffSrTJ+3&vCN zK#0B2OuMKVYP7hF>c8yg1S}8^@e1}d_dTWeWo-%9V>Xi0NaIsFjtH{zHFf6m>x15n z=_iQ$9>-S_rOIEXfm%&%*>;~z!(=rpyfbyLb#;Q%f7;y=d%os!$Ms%AXo}2$jeesu z%ntQeK?-k5B&irFX!Bor0ov&K+VB3z&hSoE(!#wCQoY1B^dJ7bEE8!)JWO!c_E%X==Z^3tU}0A0 zbgUFDT0}m~P-(WmIn)0^dZ)OdVVLJ?c?p|m=p4wTO&|R2-+HJc*7zf9Im?HywH!~$ zQw??G#-%Ch5!8=)W!&L0mlVAD_x*c;v|WMRFiGlK42qLwb>?nLj#lUSsF&dAs5dX` z?dIlyQt~bp+yBko>22Q^dF7)mBWrLQY?rLWNluaaxPwFFOB@#*d6(~D(Y!d#-F#%4 z!jBAz|9kuG(DP$SHn^Mn;Un^ciBGC0r}~DFIG}fn-ndH?2a)zI%VkDtUDC6<3npBn zBrEZEP4Z<=_9HWrZ|Lh&HG+GjZTlHU4Ch>n>W~w8elo0!iiP>{%h zQ{I{ECZ>&mDzsAmwo`tn=lwW$WJeTe}b!Vk|3F>?_`tM%& z`t&N437!buP2fps-Uu!izpZE?FU&M)uFfisbeOFb|7eZ&l^nz*wO(qi#t+1P{EBxMl7OV1cm{lAr0@oO6K|;fB_I^H*yn@mOoF$ZV^|%%=+R3#`}!#c zu(w5A`?vlcEKjuv+{bZOImk4JH%MfqEyqqs5 zQO9%#(XUk!_hxGY&IZF}PbiG~qeqfH!^AIVyOGV>(F>LNkjHD_t` zaX%%DvU+M^r5<&@q{~w*^dJVI1?WT1UH}f4m&B)TY%+vO$MTtc#^)Gype}M}D_s2! zoKhL)eTnJfx$TD6jN>v{0<#57q-$RD27=PhWq=+ZL3I zYKdUSBe_OC=he_zqa?Yqj;jX@Y9|6`4r>OC>S%dChljd@%f<}rh3_?re*$@b5%v^a zz4ybh#Q3;p4F~-=GuCX|fL;u*)0#b4ry|e$P%Zfs|_x{kASaXX0s$!kQqzhWk^uyA%-JBnRoF5 z7hLWfKjZEt^g1A^U8{FLph``EmK96P1#Yh#r+mKl7l-I}p?-x+IBm}Ck4uSGit5IL z6)pKKd=QQxJypX6BSQTGk4un6=fPqVmJ&ZsNC~AJJ!U`kD>!0>^$ZNHKEM zhYMZV&8gn>bewrU#`9+fP_nh}uyMwI4VEvmOj*Vr#(vJ&!(KYA9|TxUhxb3pO&22fwT$An@OoYE-JupYcwp_Oam1!h!tBga}L=V!ls zd75LQZ(j|OM?t>YqxfggX9FBrp%1VN?eG8clOxH^_2VRTt_3G)Q7&?DD==XbQT#az zd>y2UjA23ABHkKu>PKqgDav#i8OVlju5i0K{qT^=>Bkg{%#Kr2u>R8>wL{AsH_ZAe z$`q3r==j?sN>Q0devDVNfvAXhc~j}?JV$&R@@D0h`Wj&cSSpwu;&?hBPh!sn6{M|G ztj1^(>(!S#$M*}i7-Y+b!vgs*#(t@~S$AIOsZ1yk!<6weOsIsw-GT%>F8rnv(o=tT zOX+2wp9cxgcyCwu{5F)ySIp}oS)I{?CmOE;R_#wtawGs$=qJLk$>sby2*7WFiQr{B zh*UIlsX}7D7GnVNlvu8AsFc!LU%z2CXxnt%qRECMr*|B(4eDi~-$aocrE8;E6vgiB zhGP*_(rKeB4^cvGv~r3c1N9|D;9eazz8oXOMny3V-a}DSco3>MY3E8`ubyKQlKEmH z4?GLC&c0#9F?cQtGL-K$Z^tLm`BtPqS%^V1p;ta2x-+nSjf4fykWk_^SrM#6S!wY~ z{O^6Tatk2tUD0kV+~-%r`OS)-G?~^IpB~n~bZXpsMCD#e>~l)z-#kG1us`WNzgm6N zuZk_l;KbO-{2T9a2d#A0vv=dPij)jXz9ueu+yOzkp))%TdPGeH~ph(dG;&jbw~ zBqgc!xGprppoa1$3s8YE#860x(b|+MmaI~;BAXcHIJ?AMN5Jl-H`6U*#x_Oy3C74M zeKpTTAnp@Amh9(s2j|ytdO9pyWyo_Ipzs2>=}z|6sn-`0b_8@KJECNUP1<|^@mqa) zU9Wr;a_A(!_*+`Cx_6N?)U_MrzyC!Y{~p<4rTfDn2y^xC3lt-LzsfWb*pDfDZ-fv8 zEQe!!5a9$U7StSC)iT`%Sox-O{u%T^etuq0yq>7u9FLZFb1vb`J->yyhajQ-Us$u!1O7*{_4? z*(v>TlA=4d)Mrii1V~;<$lU5%EXGmY5|Nfp+lcAo+C2D}+ESjRiV)Y8Sk1gzj}vzm zWV2SY71#mQY~EpPZ#*ofrJg0Rg(c&M`Eh=5W z;rT6!$F8!$9+hE{Rv5G){bg`29_5fHik9irl&1I+osXu#Ti9B{{Rg!~dq3j7#bv)G zIWp2R(KYgKhGG`#%93o@2Zsz+z&9>>P@p7}FqxSv8nnL5eh8yJiPYg#J*Tg>)-Qxi z+;`Ad7v2J_S_Q4yD&0JLj`Me3?|c7uet|wvYNk6B9^sv19^uZVN&6+e7LvtW;!xiaPYCfz(G+JS?b@QPgi%o8*e#cL3%PzXR=#pCR`#U(=?DiLsKQEJFJe>**yXrSe?_L)dK8|MIhukBb_uq6^Qa%68!5 z=%k=0App(=7cwAEoTr&f`CAR7^DBfbvDOfe0*uC3qC-{$K4e`COob3$r7>P-u0dbY z@w(AzRk#O;COvfbRH4P2dq>X*^zV|c-o-!n&Fy#ao_;iT1h$O`Jj3M5ro(_gCe?Ky zL!!4L1WF!e4j0l0!@a1Sl7|=nWAW-4IGXt#iEut_%Sy&%2t^0h za=Z-m{cUg!VPcO~Ug)L1XL+$(*Xx>3gF=*P>nCX6$#f?BCj$|OU2PR|tl!j;=ui{P5sto~E>J*KT?Pq>~H# z=yx>#`*PeuE*IL9+LmJ50qI@j@u9C=ogyN|*J<S;J zO@zOOiVwZ_Zr6!CG8`-NyH&M<{-z$U#yzjp$ogRAHA}7Qi9GIQpbGJmDj#(TuafU)z+4otlO&~nIAa|^?~L~ zi#&Vu^+YQ(oZ95(+hhYC>Di>55CvXOcEqNfCN?B@DdkAV>T&hhR-W2x(*yKt(})R2 zPJ=d$6NinM*UT>yQkHn0*2*tgn`YdRqzLYI!>kw@oHArrX5E1HENvU@#kRY~o_imq zQt|lig^%Udg)C;qxSgkUkTkB=78LP7uT0 z)cDt@kVkc0st;ul%;3F%Ha*&F_*{XX`y&}!)RokzEGHxNI-_y5fE(ImM)ssy!M$?t&SI#x1^4!KlixcoZhJLu-k&o&?6@t`1&Ju zFcP(u7Nh?=1yLcj9u=Esq?zX8nhIq->U#0MD<;JWKkCjVg8gxe7gtOarM3SQJK|8@ zI|llanE9+G!%SaqTdXXbE{)f9UJl;x5%z7EMd#WJ7otwo1A_+~LWdFEt^XAoaEWT` zI41*fY#Kko@7GUuGhbuxDgDy+xJZ@5zaun!EZ@+6^%@eWOYd>fl8ZmbL*MQqR4S9} zI4%WkcDqF7IZb9xm98;QEAyQ71xX(6f7PZ#IB7+i}?}DpisQ|eHEu}6T`R+{5 zlpB(5iOnHXOYY_b7=mDz@_QPgZni=ngg0O!fW~k-9gnqwib@{ld`ERe2MXoZ6?Meb z*pTZR0E2)z@R3b8Q?9gS8q^Lbw`0Ut0R%voo}e{_bkWRZa^RBtD_!T`UToP+NW2B) zfWScXFzW%5m@RG(9&x8kUB8eOJj3puY?uLiF~)1_)P^|4v>AT^`VIIFc?zcj&RI`? zUv!q0ZlX)`YmhlY{U^0cywFNJKRF>D{RVUZw-qEy;RjX!|fl7i(L1pOq2EhcdTx^1PyqKg>Y0e=_$txS4KCtTp=)3j%R1prn9R zY_Aq&3H0sGY_xUXd89mky#l)atb~%%1h8U1su8?aA{;h*bN2pnzr|C|RaD;~0&F3# zLZ=903=n>_@cr4uTF0YQ$>-Hmp3cgE}%EMx@qd6lyuxAj-|~oPKzUZv;o4$;BuTYFqV{jHf0+Y*1BHeMh7BTDFc6Ym>wD zZo<~zz7WH}1VLjx-yk5--@UCMQZLfVFa{;RU=bYUvsR~1t5_*=vn^*x84OD>qd30` zMpf!3sKEfWh$BYT-gTzhBiXZ(UR`G7Go12cJ<6)qs0IBjP?XN^>8)0P)}TCyd%Geq)WCp z>trhFr$m+Ge!!> zmqA&DHKWU#EYY@*?yD7mtISa#rd9Lbi%M5}%guLFwL-C@%e>7JZFMa5w+2x6a|D^|o!H41Oe5X1Ml=0gKStO>=v$9m4IofdLd>Ax z;tr*eBRQ>8JC+B9cMk=6es#^4_X=YN zOnD%SDHK|W6qXaq|ITMUKb9=&sc$ln;)knh`b}VY7?=c#l~1a*tvO)91OW*D)1Zi< zRUSg&en} z@O@%$AVo&xkvsuTK&CO4Y7cFQo){@Zxv6?@!?DH{Wc1AW@9%GD1Jc$dM-PZ~JlKHe z9OT+EOh|&)0IG<8E(Q2zaiJV11}GVDBixZ9PnTAM-!cA__kD0C$y=&rlZFvE%0M$$ z_aA->?13trYnSmLLLwLqn~jAzEcp=IlTCu;5mc;t#Vc z=)HADlmp?$BsDPrOw)+@PrVtXJ8);xoz!!V)k#Ls9pcMZ$EED!oYoA?8cCh|U|-DP z63`bS;UOp%1mThv#-=%g5!E6~N&BqwX3krLqaTu|@Pk-Q7o8_;52+>$TBSjV;~8Qj z5MN-?OL?aA?p8&RdnDjPv8RW!WAuFs!O??(9LlE>(lhsCAAo4BYi$&>({T$m2gtRN zgOv_FikEtN>6gL3!j%nh<|F8zdjJV=iJJ^R>{6urWG1j=n5T!w%e&{h8O&xc1dRl^ zVzYAzSmE0}M~0c_&b7Gk%eSrT>e z$1V7yjA3n%-J2j&J)jN*udbcXGw`2=79tEf>=d%Iue~>uL{Z}EimJqP_8wB468wqL z{W`&^GdDWV9-)d9`U0SyGE>sv;}lVB;p5DA~FLs+Uwn#Mcx8~dk6}o z72&oCB9SG&Ll2H1M*-zV)}%`$mN~n-MUJQr9ZWjN$w=TaQ5zF~K5_x~?XRROfz3L6glbxRL;W#C2urFb45OwoP;X2Fkay+|83w?)Igl86Vq~{v-;R zwoZ-{6B`ZHf?ny)%twR4WDQv&7ae|j4!vFg%Tpi~W<-OTB-Y|O7z`ZQH1vfB({Pxh z`f8ls{h>cLEMNZ1Da@n;4pJGI+$TZ_bs+;xg~aYp+|vWFK8PQK?}3NU(OY54aD$BD zyyLJ))!Cop(g5E}H@2swTF=qNdu?NIDbaZH68Zd=h9-Jd-VuWm{tNMHS9hQ|<3R zESBa{6vzop5(&m^(%@S>i+I2c04yF3;9=?po#GW7nx+J^>PYEFax^`|4Kaaac}7xM z%2L+jI}8_Cu`uloW2S#qjBo`H)b(HCZ8^C+x=oMrRa3QG`w10tU$W{?f>KozgrHL&Cn1SHnJgbWL>pin2bzfEydUvkXJu~Z9%!H`kunsCjgPNyOi7DYK zrvj5+6S_tm@_ybhXIj%$pW23mpI2c~J4hN9!^vZ9kw((r#foXIyIeQQX`VmHE8Z?`NuLbRCtiz9>V|DmA8D&y#_e*H#OQ;b`%%-SB?AxkjIT+0})iw!8Aysk_Ks=>OI5 z@>wR4QJa4w&TBr`B;Mm$Ko}jFd@@0i&hK)VtUXyUg{YSowa2v$+MzP{^9AzrCB1V; z;I+Q$cz|=!`Rar4;~DUC>HULbdRCR7doF7kGX4}kRJT0|Y zbfVzW^+Vm%d0Xct0>PX?wF+@1KdSm`w#=Bb4@m=uZ>hH@S&DO)g8o6An^rnb?BywC z_uF+{tt)uxDQ;3m#c=JCN6+B~%mtqEspIE-aY~;1(d1bfa*yRG;TUnlcu zu+wbSn*OP1)qF8^i4lqx0?P1;@?v{EoYPYkNng z$j#lkT-Tlanu8$3jO?to&S_MDuJfg|j!o~i(M5Mk$XqFQ=~b}y^vdf1Xh z_417|AAO+3o#@8ai^$vCvo58p)#cHwnx?m2ww##s)d|aAwdP+F!TY z7UM$&ZK3^9x)G4F&pwfhs0-C)_*m;m=;nH}-Z_%h4cd^`)nC5xTuXl=ZI)b1DW{J; zpgL>XOQku656*9x&}IO)M^nR5(L91?;80G&Aj}OeOd-A4f-_-e;CJW%(S0Yq@t8b7 z;Og?YB0Er*59J4G3a#A&m(S^0jL|Qbt|2*JSMz9P8Cz5~FrJhUZZfZ)GzcG_#4h&3 z?=45+m2+k0BiGP16Z&=V=&dQb_b=O(m94GUoKN1=ZG!qFJ7`H(EfHsH0pG%@YhP-|Vg*H0*d>;ASRjEG5$g)pxbTFL zna~7+Wqya_nSt|-MFh>iJLnr(4J-4Dka&58*}F8ULK=t~P4}I2IlL`jAmjS%=O^C@<(#A6Ax6#}8LOmH(RMoA!Qx zAtt4IKg;YfeJb17tuR}wG&ON$JqE~q8`}=CVa)GHz4-NMeU+_8C@eMtnoUl{q!MLS z*t{}|u&)BG4u?L-z2+ni6gTySs0P0GbIaM{__+@0UNxxaik{E6q36uJT?v|v@$SCo zTo3qL92k~&1=Ris_>+GZ?Av}}Jv4cs{k6D%(RX_Nz`u2WAx&_s4S)wEFBn>XN`Tg83g5yv~dBIx`}J$>^lNl zS8dOvLIHt>Bk=_PBpTmdgXaQv@?=Yfz(>n-wt}2D+J7J?szlI%d*my=qIb!+dt6af zrlJ^zi_Yj)KriOAw1}QYpXF{qA+KHA;JJK;h-qSEIu<&QA(5sZWAnSTs5ILAA)4W5 zUdZLl<9D{bd`n-`^v;6{`D_?`;bdnaV>aEgg!CzICGT@B3n?bV5gVj|wg(1Rqm5LR z2Afz(PDnxyFalKwXCAgRbpWX8s&q}*lEez!bAFslfFzWFVHV3>1}g(_-XSEA}V`@?^n_R5M71fEA!)DHdA2}?e5 z*Yr5b<%C}#jwCy{#{5gm*gk$Ch@~sSV!A95NjpujNqsI*VL|S-1YeOI6W=nMPt%)K zGiOZ;>MX9+N1XF&(s-Y*pr$8#^lE#DPXO-ozqWdI|{_2i^lMGI>mq^O?ep zNTfx0Z#Le(To+lFN$Y}D4qi&$fn~OiR=g%)pl+OW))jT?uymGF2QGCfdmodersG@C{WIGiF(+F+Mr=A@*wDqv57)OvD}4RI zI6!^0T48wQ6oycDN6}Img0UyZh}+qeHe(%ej_MPLiNPC?FfS<9v7Cml3JL(_9+!>! zGi6HCMqY~_mzxY$mZ(?tSQa}e1%b$#97gt+@sr8XB0I&TfDkK$$C%NQYK#EH0=O1p zeLBv6nl7P{6+oa)V3Bx?R_7;t&7Qd0=DKXz$ttc;Y6Wo)wH0{BLmK;88S~b3Nmn9`CQx=8Q7FQaSP~+DzyI|C4SkcZ znB+Cv1UZW?uufIj9<=N@jzY77iI+?mIIcp0*Z!6?AUDqQ@OdJR35Yf)2J7*ciWrTV z9N87l`*?#zN;oF|5^Vki)T~m4XDe8RbTe%L1#p}`aq;ZN8#RgWy$dcMteuLkkSe2kV2PCWRH&v*R1%eu1MlgS1RQ~ z{dI79PCZ2GCT!JXCm$KiQvfFiB{26O*y19FJJB07)bgFwqcx^K)?}Fmyq$6M$axl! zb0V*<0BvCmv2nKygFfyIXMnV|A2JQau!1cYGXJHNSbpJ8#(7LV$Ce;ATj5REV%1FD z69V%PDJRYz6SfAB+qt6ED=t&&phBKi$r!JfcApC*V#9&yTDBZX_3y#tEG7jiEtQe@ z&Ie9p=)8~uc0AZDkG3#wx+Wkc?Fe4^{ zR}0a2;=%k0+p3yVJ#xrH!_0a9kH2#tTvFfh%3ctdM$> zSnK92KeX0;3k{ptOVrgrP>(qlYah9gRT^5N9VKQElBk+Jxbng}sL;Q>B-DHYut)QP zn%MONvFHt~Zk@yBax^-^1B?*xh$>v{*g&(Mx@~|MfCRS>)$Z|xt=DYFAyj$!ba2gT zQnfc51I|Fv;vJb@|qFv{;XXbdkq7@zSl zy{il_c^Dn^$AXn+?hxD94o`;b*u!g5ni3XwXRfDX;f(z3!6AzPe$RM_$-qPyLp?CU zH~vzHF&H13;dHiXAr`(1qz=}vg;LTiBpi*Bp8Vs@k)j(RMN=_a!xriV-1>Blnw8-mfRhbUz{~oe`A%xz-CU#MZpWg15^fF=NR&m({dRI!z=8YTuyF=qaMB#S*$(Ru zi|T@({O<87@OPjfD^}w>c2h;OiZ&vfl8j$W$sI&E!@-Nj@3%f=Z1&c@FnGR#lh#HE zcSVWG$?2^%m}h@I`9wTHcaAYF#hUCDOm2EEuL6(_a9zYc1xiw+#EjDR9~Ph>V{L++ z;p-k8KPM|BBt2I!8MZYcNE@ZteAzw(BRPK^a^Sgp2SHi7ZGEz+y3DA%>}db#IiS&2 zIBG5!$mX#x3(WDAFQ+8>t*VO5JB;NyJrkce;l`a)42=3G7x3K8N0D)U(TSB~2EV9} zJ6y_F!ipcAim4jVCS9Dx5l!z+kH8vUEF)TYYp>ErGehs-6Q#YQ{7|%>HvoS1O75ze z<^1d`fr2lnZyHESI&{^qA;$J;Ab|=-OU^Ct(*$|wc}YR zyrB)WsMJlA(u5+VttijOSB%WkSCeR%Iwx+(6@YjWlUaEZqwNTJ)92ZGn%`$PS9M7b z>s0m?BxdAxK>*JTtCE1vR0qd+Qk;AnQi82JkD#)*)PaiaTtB~XH^McjB)gy>{`f5D zBWd^R#h$$V@HduT0Y^4FYqB48w>45D4z(JNoYMib`{Svp4U$iLEO~*pFYf^kmX${@ zDxJfqE0s94{cl_!_$@NQvqMnNGlU}}vC%lBcobQq&8iGJ+oX7!m+h|kRP( z*L(j@UasqJ2c@^wveOz6ARvD*ARwgwiHV$umK->-E` zVd0H3%^q}!v+ML85$7b*CGcv!fK*=Lqqh`tayprpprd zB;nWuyH~W{F7lG+ZqJbBuz@<0%x+zvb+s*iPzlvDfv+Ho1MFne}RYW0*S%RW&HY2{TY%aL*ATT~)xg};tsSKHv9k-{l*C7Z9*9{HAcNJeQpW-^a z8^@eV1Q$pOB~vhT=6dCIOvV^MdRy_aBxaZngHQ$XqjW<5W)`xr$q zz;fNo-nC$3fR@T{YIP%Ug|7Yw6@Yg|lvf!r4{F^b@HyMZI5mSijV9k9@<}B&LCB_LOnwJ|*hf%m4slhyysM8ye?s|OWMo-cJ-EFV&0*E4 z#I%Q|J@882_ClQS3)+xIvj(j(Jf{2>ZXDX0uxB4QGcb)ziK$2ADe_TB&mKXV9|JqG zLkEhM9-R7MQhBptR#nfbecWJ}<5P1=g{_cM+}7Q-o&hW+Jnn#DrLlHQTu)tV4@uv# z=5gaxkDVB_)g=v^_pF`C*dlJ8|iMUX=l`RQ;cx$ThunCV5zsA?v7%b_SrcQho$zkWu&t6z1|gc z5;LHn3O_CP2UX44YhUZxz5iq;Jc~a5 zx}%5y$0-<0v|M%X21F%&+s+f=L;!;@W=Dor)$9wy3ky^AeNFx8eWA{u>AU}!2~bS5 zhE`g6)u+IjSv!oWC?$9R{qOoJ<~k_N-qjBLr?x!+ARxs5OIMV|ghb{3x2#yuHtE~` z8~>xaIck$m3xbGUA2g+$ioCe}0Wc2zNTJebr2TOq@`hd5Ycj=KHNK=uz(3Pd(v5>n zl<@Q$Ra?2&x!X!mIJVTbEx=Y6MAwjd(>qhkWleFD4{JtTVd~2gaRA&(nN4M;3|aIC z_lu4X;7^h4a1Dwp#qk6q*4`QrBC1MD2ar83EW^OLFKm_!B`0P$td88DhCNda*gtEi zKb6yFaz*Ud*93CsP=5uIA0C!|matpDoX0Kooo^Plhl0A-752Q!mSUSMNi}gCOUQ33 zKn@utW`Wst<46e)$e=6_YF?#@${xRBVT&2xKM$V)eKFmIR6599?F4i?kzG|Sa>jLU zQ}F|d_7;$&Xzlj3lh3&HH?LzTETl!{{wc*d8&jti+)(F8UU4LQ(|E+7w$PdeQREGd zx^Ws%#J|uwQFe3b%hMx{j$XWeWF#oN%vUXT75Z+ZWNt6~bUeWEgI0q zOiJp$=cW(9q5w#@#Er@rWyQ8}xsY685R`n)p^We&Om*p-Nt!zo2T2-da*Fz>N^rCvWYF%`KOrJ}daUVw;B{x`mlm0S5Q#XUm6_EH?JdTEek{a#F z$Y2LOf?6#L@jDAx%IWC$Fy|Z{`Qo1t6Iggd>wj!;{X46PKdR1~>ui5yGB%Tc9P7jd zoxoroE?cAstCX8li%v0mv9wm`*Ido*nU&0wj4MjE!!XM_ysRfjz61QMAx6H1=6!;R#q^53UZr%RF7s5jvk^n29c&{t4b4qPN=Z=9PABr$+!VoYM3=vI z(`89nZ;ZEZEf!ncMw_Dq{GTtoKYd66B(-Hh<4>DN?y>2BBr2atMEE^{EzJI+B!1YA z94;e|t?yYLPEO7jh(VwcdGVzF7>32g*S}AHAHA4^w3}FerxK$&CXX>j=?@dj-4ny? z&6I?jrehHQY>-cx&@XFx5lp6dL`0S$@F}&E@*+tLS3xF~_$Rz8fL4v+z0>PrC}jpS z{cX~+ht`BZ9k@DSj2bW@8m6XgJS~%XjSW3fv46*tV!uEB9cTBv+u9FyqvzU1k687S zay`?l{{d@%?p?IJ#CVz~r?62NGARJ^j))igE?Z3V^KoUeo(DCT1=jSo2x|8@JoaMd z%=B?ElJ(A5=+5$W92K>P>j92?=IuQ5siq%zYdB@W`J)$@MIr-o@m14sE9rOsH;m6@ z-QYZClo8nQY-@^vLWPKakW>LB9z^}~n!AtP5-u76bw&B{2raNoje?QL zUWk$LuK-Gk4~QH$zDuU5Q8(C3#L$GUk}f_LlPY+rs?qfOy1yC1GFrKRvJzB?7XYuR zmmKa!y{CYb{Imi$=ybx&5fF7+Yk|LWn08KISP0(8dDwCevDVm~`Ijvh0Bd$^``4=H zd~qV6bw2iaSH2CDAbG+Pjx`O~v6Hiv=ABd~A9f)O6c+5PbK~5GW164X( z##hS@9UNZA7D#;;5?C-mzZh#mDU-J7umOIzG5O7q7@cUctKJZ1hg?cJUIsc+G3Ix2 z#FW9*4jDCrL1tQHs4^}ca3QiQ*#yX8>XI5gS~A4z{r*_*f)QQ^0Om(5vO9H+ni{&jn2U|8iSe!ADx?vg-w0GZ zbjX4#H4C<4{85ZUED=i3ZV%wW0AAi_iYUHsbq=o1Sci!Y3B3x94Ff6z1C|WhyLtX+ zSeajS%!%RP5gf36$Z6V^x9Z>Q=MFf>2H6rKhfOw9*fOxIf_0)v)GB6@&CACFyNIGB z#8Pyb1)!*>w&9v&5hKm32nl|Ud7XV^PD5`1c=r(KtV|*e=dlDMgqhN!DAZ+-Ivj?l zVBRJ4<>R=w>PDw#)sr{oHLB-LgA=1NBa#w7fWi{TFz7f*(KO$2=`3wS6O=>94HTVg zd~Y4ldn#wETxZ>^spa~l@M1&|39)%8C7QrOv80AjN!y7|Ysp`1VMw}n>lfUnaHn-? zEO=U*e!b+gJtG7??=2Zx^KxFcAZYdPrMYbYV-55ofV7nXb;nb5a^rZr*EG085*g1f zYyERFF-*1AlS>fYpD3kXOEQtHK(f&2&0j*)66=S-jH}ksV(tRfLR@jb%!*JTi&7%= zmzNL@YBdA(f#tY`dnt)V$>Exn1QBB@7{cR%Gp+#!aQCNL$bq5c*IBW$5FO+RcQ>vx zK*Auw;?Na-{ranFZh}QJ8-$9}BAOL4zpBvJ=NbaRTYQQPDkH=M31rexIh<*BXnWBI z+@dTy^U$Dr=UcqQytP?$vc7o|MXOcxRUx{Hh$M*ZPfLb_ZK@U^GLmdU#3peAmDK(V z!A&T*kE_V1VLU>*fmSe8lXrACP3T-QG<_uk4PLgdaAtZx#V&pej|NFIU!)SusPkZJ z4i{g2MA=L;vmK6T0)7sN6C!XVu&BKMM@w3Tyu|J`!S$ zXveaU#id+1tk28fa1ws37VfE7>MAzR=orWY3)YB)Np@P~I5oZEb2^t5+R2{C@WhGf z?tmRaue7p*$_Vpft#sf6;h@oAgT7%|m2l?*|3x_Zsp66SOIyGO$`peh@on}|AxVn( zm!Lv;EC7$$rw|{9N2e2?=wAOs^4wG-c%6x_*kZ{MRiip|>^CcHtT~PC}Sc`M0Hpn%GU7w1Z{BsiK1SXQ5Ed~CFpXBF(m9W4AEf>VdCF&{8hLa z3GnyI5}ipCC@`bE;eJdXm~gfMMua)$WvUPn1NMkU3j+VMa9h=oxUkDK%%Pp2z3gN&Q*79oU9+{7wE zh>mb}DZD#)aXQ1%gh>egxUV*7A{Vc!Lwhuw$AE^KD4$v|_SOtKMo;mazAwU&e3Nq0 zHdQx|&{wj(f9u@3^op2JgS77rn5odHhM7{f%Xd)0fs-kPtVHeYOUQec&*1eT?;(Z= zeh&OEc~ZG{;#hbMk;(zs#>&T-lnQ|xs#2$4OgU_^HbsqX_Yd>=-XbAV%=@CjXm7)` zg|m<&DUAe3yOk(^k}P2;qubz-Z3eD8P=P{Uhi5c~rBrs=lA;9$?As&-RvnWgh;@d+ z?g$p3FOKl4pHg$r1oYNMb3z8pkziz)2v9(XU?6X6d~;-7SsnhIF-q2kn_Z z0KM?0g{|Ld*WaISuJ$X+Oc;T*-xAQrnkYC5nF}`rjlwmCN|MYIO`kSWpjuciD~y<; zA;+tOBED(+ifytth5vNFbnq9XxN!p5;n`o>;n&T}FWu~cOR>wBSgPHYuO9hsTr%w3Qkpo*xJoz~IW5Gtxb zp^wffWt7Cr+F<}tl2nF7b)N|ASqC;f*m8m zuv_X{{H{?9_yvtO*qcWj>A^K+{p1+8!M}tgv(abaxnd_5bUV3s&1{0#l@=w!~R1Yl}*F0GU8dHdW zQ0qv#SyQyufx2snpqfx3-Rg5TC^T+&(7a51x#%BJkh4s!X|Ng&u}7rc%QjCSGy%v? z6CJB|?p{gc5)(4EpL-OgyH8I@usMlm3h9bTGe^}0ZW-(m^T_NW?>^S@twy!w*>4XT z;zJqm4P7G~Nm0LGWcr@((iE``pAxl?HBehL2xyAcmS`lIWqaUK8(B%z>< z8G9N*mJSSWOfe~hSq#BZ4j5PqUOHMFS*;b28Y5Bgpo=J1u{aDfvob7ILbO4M!|V}4 zd6OpT*gD@Vo;V?bh}b=3I93!?l`$7{;rf5LqO*+ynoQeBD)QjICq&R02a!6f0P*FG zc6%*{H_aHQCgZZlZL5MR?t&Q+*&~3T|Fr^W-wFKxBZB{z*^m1}@@KeO$KdXB)hF`; z|6pxpp`?jBHTF02x*&hxMZ+s~KU=K#CzS1CFjT?w04RhwQ z7J1e-MNL7(8ZfDZD=ZXYg2S(huP__fWWcEi3kmS--iR6qRFqx8;w9b0O9E^PuK)hl ze#WP=j>y%+PZ<3g^sV@tDl6`W>@w+xeBC$fq+uA!7&Q#-8T+Yy_GKI4FYiY9bNlQw zjNY+3xhpEN`v&^Iwa>6f*)lx^IyNv6_AlW}`wZBRh!WT>QYTJ%?^j|8nOC{*R3*FV_2#2K`U|_1fvbm!s;4k9M(mo9p52>OFq;o5~RHjf`R!|$zG;`vzese%A(E6P+uqYD`n}n*D_IekF z?&)HK7RU7b05_@XhhgGoVOD2#ie-nQ#)FDwm|%0QtTa(DEkdvuVilo5!CoL;Ix92Dtde>1ocwBNbI+gAxcz(%odQx;@GD!TOJkZ5qQ-l#6NPup@iAdY0`O} z@~bAO9mn3VF@G!0L_>R5L%z%XT`+7F{xlt4jax+6saGpIufnCoLIJ6ZJM!J*cP&bh z^nHsOUSsc&YE1h}sCBndn{fT;uXJ7Ap+>5M64eGGykBo0vILF_1|O@?=tsItOU*TU zZ{Q&gAL-l$EdCgEreklsqL`hcHr;+lgMcF3GPjJtz!zXDxf|39gNlK*x%62O5@JTz zID7A_-1^wq(FrCPijV85^OntDZ6FseftyNannNw*$vFR?l7XZq7dKo@K2i4Onr zT7L}H*dElLoPt9m%{5eVL;^&02e3U6+TwgG;;^ED`N0Mh-~s#o(1XNMZA}gzwsEur z&|+`eEh~Fd%_~1^`0`kY^LL)}XsRwSkHHrf)c(zO`B^e@rnjpJyABAdt;=~wa_qV# zaFhN$o!8{xno@kcAbcUQ0w^{W)87g5Xa^eklIbeNzEY;>p+rxNOe?mT14u(A_Z>^?N+wZP|YpAspMVN zJbZ2J664Y|nx1EtQmiSVNicKU*Hz%M9QaW@rJKhm(_FyyhoLUZnqxoV5eSU= zDC`pHVzJ3gTS!B@kh;*F_HR)&xT#omFgxmQ(=d9N&urOFlr;}jC(>}US)~iLX4R%) zwWc`a3|RQJ#KT+4Su~zmQnOSX@NSOMGYJEZV$Z)7=9ZufAy7Npq;C4J&W~?Rcs-50-K_K-lo-#?Ba#>_AxSI12 zxOlGRBffP=EN|A~QG%%%+vc4pq`Cc`Me58P4YHWiJ-ZKdnaXURl!p1HtM6|O2GXdL zT6=NqR&jiH5xaWroHVgbLye||DO*%B{XOku)vL}f)^zUbv!~28QmA?eZ}Gpc&{e(I zT~m6ll9=#5eJ*SNdxWQQncR8bp`o{cK+LO7sPZB};my%9eLUn%a%9pRc*CPOXauNL zPE`XM%tz&-O#r!wshG2SM5<{!s(Rg*TPD5f#p4DXO?}0Dl2fm^zCH^aZ}W)pJ*@fbpI`I; zG^fWQ&=URS0tEb;P3+3vq0{Y%R_E&}7Pi-GS9}FBbu3)2u8+^+R7v27`AfRR;0BNK zeg*>>dt(cPIk?I^R9ggqO>MEW^r3hGC@6R9LQ=N{EU(M&^-ym=nbF3S-v_VW8GF4; ze8a}xu*K%>+zT44jqZ|#qD%BpZmNKcKY@B^GQc{L2zoP0_g?X zzzky7XhC~YR7;2!n6KSV)zLv1{#)mio0%a}lDY$6v%u0hH&s&ue$I9{lh1TG3L%Jp z6VuzCfpdyzm}L;6v zPvQIZ`1qvrnfDB7Q9#1!WNMnv;ZF4{pe_!dU;b`}f9@RPa%oB$efy0LnpTGJ-#E~$ z4+j2r3`qB{v64?1F2EhpHU%znX71OAb&o$I+oqD&LW_LD3bAnrxzru}C09D9z?Bmm zwgNA*x24c z7|i{FKjk=3z3a!k_-CNs<`bx=>o2k?kBjTK0hyNo@u713hTT4uyumdx82@hWPXllC zC)G@86azUx4Xdb@6~k@#3=yFiT($Zsy+k$QQFYm=svi+`KbNp)!+2trM&4o2a}k0<6rkOa!#k zR1j>Hf7f6*ybvwIMoR=_NGwaOPi^%KV|ymt3lDH})m`8`+^aT(8Kiqpa`A%`Bd$o8 zGz;_nauXE$zU$SJ5;2vOf2!a)9tN$z(FgR~Tu(Y~i}|HrZJa<4;)|Bz+sD@MwEeLy z8lLEuPk_8yA33Q!;@KbhRC#1jd4#$@l-+H8QVzD9q^f zM!xe={Hl)?95Aqt>iuM5d;{z_*KcI`8g_+pnKNGbp| z!MCdQ#RWKe9=^&17(L$M@|&#FBh_Yr7|w(j2#R1o z>b&8QVZGlPfcFOUQ6xL+4#x^eJMaczCj$*A=#XJh-?2RGZxo_PWKdJR=&u~*I;61q%gD~zMVA~H&srsjqN8iRZ;k`rx>x}yEM4JFPh$%)42D&iYg(A@^JVz`|9L5wA1&=6R-1UQ7k zX}fY*RGudti=1_FdZwvRR9b^hB~}sZVKq-bouLRoX}&;IE4i=WgBVCkRH0wGDFmg9 zVkrg%Ig^Ri1vUlWUQXf#VY^@K4}vnC$lzP-SxpyKcyQfKomkBWBbThWb0$Y)i@>Bc zT=z80qCHAhQcHB3E@mt`YGBsF;TDWxG8C}b8~yx~cB{yN#F7kAa3AxKi4l(7JUknU z$q=`?mysc!g&sWPHAL+mc&}Wr{fja#nnXArGFH||Vl!;qD2(%x0S~?riaJ)8cA#x5L_V(Ll|T$ZlOgmRnNR|&Nns2Gs+99g#WcyFL;~6x zIJ0S!3?A61p(D6BHP7OxqPP>-PD17t6gxCEpv9?q7Uxt}cB+6pW04RtqqsvEB_HAF z8o)qkbS&Q3r<@8TAEuw@AD%ym6$+XN8^-}^4KxuQR`l&x>)cmLIZ?$%eC)MeB`4UZ z)bBdGW<0=ob%v9|pd9T7Ftf{2#4-2G*VsnWRiZLi2uy{*Qvq>%G$6hXppYm&9w4nC zuzARq1<`ThO~fxQo#&bsVm}d6r14;n76E%24fejOGqsANoWqdH2LfCO88-PHq_817ifG`Hz}&R1fcB!T?4}SQz}ff-KhPp4f5%Am*nk1P>;YHU z+Y1$SF+=NOTpBzW6|+aaLnRO?D72mo!570Vq3GUu5DE;EfR@4ifC8_(!y6YOqJ;QX zJvD*Yoex?D%TbKcIelu?ArfUf7_v6Ey%D#yj#}!)9EApmfZZ3JPC z5h%hgf&_8~ihm!tTieDljZ~Bx097XAaxa0zO9z_?ufg3dm#cf)acjShsSyj|r$&aU z3^eD#RXmLG6g}o!*mUrsfPc#t&5jh!MuJg%i4SPMVM~b}qS%u1$K?}Iu{fF z$5#dswKa|T!exd>Ja97o_sy_zJUCf+rN5S$=SYCWreLZXhL$X8zS=^L#R07}_zhE5$>YrCQ>Kl*Y;pG`MS6}M4Z%YAEXH&M=h_wNz)y?28X@8$uSR`DA#59QpM~o^YGR+{ z=3-IzVJ)as2k6f}7jPtDI(7m?(yM~^eSHq(Ca8q*t+(Z2Q__tWif-D;NKV9g6Ec{@ zSr9A-Nk5MybrS0AlT;CydBVmi3*oVNyofd|o81yf`pM_1SSumfMsK>- za4ZtI$3xv0t&?#mtjBWbm=)}r~o)Rpfg-6x+J0+)uS;mx9>;8yc4tAF1 z)GXyH`_|RVkzE1L$bOEXGMY_O1SoV(G*?rA?0|+VE!7^GK(2Sl>url`HUM2=XNxF) zOQTj&4K^+O3X7tUUXStQru5NGp)DMK!(Dj5WFJog!MJcy+`B1U z0I~O>?C8Xp@u&jX@kS@{vKJ()TqHK299E6tjV=y8Tt~28pp-H?*^?r~1#Pj5D=j!& z=pO{;TGdof7#j5Fti^VXMyI;xwv9tUYek}E=fjAAo+*Oru{VgWqBKU?SlpB*C*R1P zJQmSr1z!OPpi3pjUE--Ojv>O8yF|$COAyjZUM5DN8bL#ZZUmuNuR0|xGJ&J^J$F9W z7Yc>qZ(iXW0M_31MZ)Gw$Of;kFZNy`#?W6M;F{a8=7Q$~4M+^yhmQC7InJS(V-Bti zdBLkI(w8?p_!^=rwJaGfk?xo;{SjtdV(QuH2pO%Y_{`sIIvp^9V(Yp?xr+Jg1ZcUE z^FG`z1CC}K4AO)+wRFkwh>v`bqoI_aIOBkc)vEr3huZ>S%qGRON0fKVp6o;O)tMp8PJlTN3k+mh@pC6k-Vsx;+$v>X-Ng))G_{tw_RjMNt=`0N%P zjLv}#2$g+HY|p+WGq;%L;&;t3xyMOS=jM?4IQae`8iq_(j`aHsg)=+p2O^=&*%Ggz zF5egM!bK77DwWt(5l$BquZM>RQd}`fIXr1K5*4MZdE(SvmV^Csbv?1cVITE$Kd6!fnlcy<2gzAW5_hod5mT&cmKR=zMI>q;{I#;e!{C|ft{5N{I zhcJlNJ>CE%3hi?d|9Xe?dKelA5wk}sjH`rSWS|^vUIj{N`t`Y$@8ng!=XjOx=u!Ry z9LWhcB^nw-;@5bRr?`-}c;L#D{Iu1!9LUKrd@}4Qk8m@BN&o8K_{j3&F%IGvF|Tm^ z(M~? z^X+aet{q&;O3E!GMeZ~!+VVSL_&l*%mJ>$HcEV`IoG=34IW2B7Crm1lMU2}=*Ud3L zmKhcMJpqXKT8==bW@(?mE?1lPOEwwa&nOM-TF07->$WjREpucuwyY@5QAI0$c;^(o zl;G$a?^h;x$}P4PbBn!9@rSj0CMN0VbOY`dzXp<^OPZ`mxaTZh9YHA9GgS8YjUp^b z`VX8#8r$RpwqyaxDRYl;gDaf`wUko`?WLk@MdxIIHY`;gk7igS1O7n54yAUs4j@}s z+P)qnR^HNjR-5vBsy~-^Zm7xFu}RBzqSmmHmsnt-(hdToo0v4uJI9+6yy=IW1LxFo zT+)7Ha+N(sTA^$;n7CJF-DS_;K<2?&M(Qw* ze_a)#qV{{MaqiH+Yoh1QL7riazkArX^ zQYd+kN_b!zHY@Gz7LhKwbB@VCi z93=7O5F&LcF5A*GD0@33eM_ipIie+vlA{!Cp_t5`6&aP-I}fYd&hy}d9m#{Qco0pM0{rwa;X@}>CZl&oc^Z$O190X zZAIjd2Qyqau6p{TBr8(ylmN7UE58&yXkmWFog}3;7{)22uXs$ZB^lNAGxKW;$ur@% z(>2Hcq5xhgqP1*=Oh8JEcjd0iU^uCeM?9*WawEsoPA-jB1x2VVZ%{Nd=*O-g`1B?2 zBmg_d3BZ%#j2CnAB+_i1`HyCIbJT&+iPr7Jv?)C|ysT57GSY#y=7*tAC5kvY1O*(A zyMq2cQmM_5D{R)Y#|MwQgI8&`4!&`CeRtzaHv}9!dKY-9re^z!-%Flgoaso{Gw1hV zQnuA+<+;4KbRIaeEb_!zy1_h~#5^z~hr0%i6w)tGwrPr<3F_GyrneucgMaJT-yHha z;}Z#ep2%-7DHSFLPWr20gvyGIzlrq*3|7_jGg-^0awQm|Jhx60=j?58VO?n9V`uAt zR-Rq^TpOgH2TK)+vvIqJDCP`lw||i8r@}&mxhUdOA8Z&s&Kv?fsG&9;lE;oFa~~_`m0mfZ6Jd{IbMyeE@Vt&e5EFc43f9%^-E?)&N&GOGnUBpw zE3ncjx8>AWlwVBp#A<`NB6Lzf4(YdWEho=U_ft+SiqtbsI=xHl8chm=n%Dg#1*i(H zHQyTvO#@#)yFX+k_h6uIW>BMJda0OSSY8BjKB;~?9r9~SyMxHBD~F+iMH??PZKU2w zgba%N8B(Nj3EB@7u?b3M=+clDrpR5fwtA^B_4^^wMInYU_Zs;wQ@TD#!NV2B9 z)fjmZ05_fDGHKpN=tI#XNJn1bR4_N~@j}vbYYh>szm+U}eUop~mtu9lq=V~=a$}-aH zobQi#os*~n-ncN+w62__R{|5 z1$%LJdJSb0+vQ5hO){wMK!vDD4NsHictyv0x{Q79dU`!*(=BH%BM>FM{#4wA<3cr} z$j9R0ammSFDCjuA^X@$cZMcVRvbd)->!=A&`946JhZRO&IU^5-QIPF&HKLJ_*A;)0 zepi>>*EhpaXN>0e_Bnc%0dU8Y)?hMr{IX7$pG)GZB3kH_b%GHmd(*dT*UjUcBBZw} zqLWc*eD{9!Wwt7bK}Gc9<-BfQ62?-3qN7=$cFVWqRwUt8HgL0&QrHn7G2+#u2J>w3 zalTqE&>M{N&XN1ot6G7B;1*57wT=unOo=u)1tkSBrbcj^s`tEs6p^;@u77P3ZK^yF3Z?Dh=+Dw7~xtCH>Njtshhv~b;eDi!SotRYh zP*(5aMb<(98b7vGo)l$6Dotrh^_uD(YQ%b8%`lA;^t^tW-f`3yt72VM40KJ^Rd&S& zR)l>VR0}6+v07`Opy){WjJ_*6A*PJovX+5`G26M5R%}wfpTC=L*iwy#mhuVt<|L(e z3~&rv0>A_$3T?DO@#P7UEzH2Tj}IpB0QPxNxCm4gXl7x97sU>s9yDG}N>pNkC2;9f zG*?_puGy7;@WQcd+0DszLeU1P0wO&Yr1|P_@-W$mx2g=qZMFcCV+Jc8y_1_H!UaK5 zao*BuP57+|h$BHpKwP^OXq9kKF{GG%eu7O4v6s0Zp^|+gymyM<%(kZ;3n{5mP~qPUqRCu*qA(Gat7u~>n~8^gD=7~F#+ZW zMCys`6G{+8Hw69^=`bmn{^-L1#^q{5USN;&x2q}UIBK=~nXz>}&8TR*0)yOv@SvhZ z%V5I6!9h7VJWPqbyF-ZFMm0$D3JfWl>R&!KEqNcZ;~xk(Vib+rmXr~5|2qh4s&I7D z7o)LgRzcxPEq@dQs{HtRAZmxrd0OG1dVo3;7e2od2enwc}kv}fe<`R@ICgO-!d>~S*{^TTH9?7uDyFH~!W z4L!Nx;8pill%Ec1FO{F}vj*<$gTl!r$aSXOS~aW&_DZ)NpWaWY+3{KAPGWS^rWd+4 zVEJKifH5UzOqdAVfK%`1@7^P+oPVHg3v$l?3)8|Z%bz!r&^e>R^gTrFSek&oIyXJ9 zm!}kxrKG*x({tPhJU8xk>T$0%I_oAMkD{~lN%C`9At#%ZlM$)x@B0c~cQqSr8G^C*azj=WLtg6lx~18)u6m*Ar{{w2IKm z9Al%Sq`SgoK=(_TX4}v!BJ;leg)FdDF@9G76?Q7%GCphKU6CovL^#J7X79 z2M4>qUq`Q6J>0u6XtjWhcjmIKr&L%hF&bu;sufF&m6@gL#S$ZFW~m1BNH}Y|7$kH# ziqMJCxmx|`Ooh;Gos5U46MQuRy%`Gkuc998f$MQJIHS_dLm(wDn}>&ofq6Z2@8Hl{ zDbSSUH$c*t;?0X{l_LtiDA5o8ybv$#stR5u`At?mIPIR|hpL{+Ppql}Vo83JRcr0m z)?O84OY)npda`}M65J*EO;tVZ)av!1MpYZtqtk;UIpFWODERIM0|TD+hOG%cxf%lL z`tgg=`R6Rg)v(ta=74C>{9g*BCH}#m91w-l2NH@@Re>}IM4_|-X-2PJh*H&)tpoN! z6st;*QdI@gTo66E20``u?0k$4L{%|)gY5H2Rkv(ljaxrK|)oK?+ojMG}WE#tIS5ZY{Hv}rBmwz-@2 z90oz-AZXUAwfaFbXdcv4mlfM=HV+Q!@J}r~2OOoAt07*1~!a z0Dyu7Ol;|@*2E(9FgU1(VWZw`)KBsuK^Js`X!2ULgRoisrIUR>HGu7LvY63`%MS|y zCCEINsSzuyfdliji7Uen1KIs}%hnWV+S}W$tFoQ#Wg7}^rv$g}1hV-L166kiP_=dd z)yWQ^>U>8~J?(~7F<8YuyI@)TlL^YxqpWVTL3?_%`pjqF>(6%tk3~q_7*T0QjX7I}z z%`G>>WXOCK$E2ptx`Xbh)f3%zFS;6c#rP!%jI!!rIDw5Qq6swe8k2mruC7MIt5Jl< zdXu4u2JPN;r%R2UqN(TxcW=8j>WH#z0s{_2ZDZ6rDj$ z{_0su1RVgu+YYS;76737J3@d$fqJzb)}R1EAO1Gr4|aS|2Xwv62UR>}>Rp|;9FlhS zZ!%M+lCT#pdIZ%Mx2YuSg-xB1dil%N673?7^p~xB%63x95(#>N1RjYG5+US~T=pxW zgC|G-h9doJ2*uc8280sqFatsfc9;R71Ut-tP=X!ihY+4e=agXOI7+rSn@51vkSW>H zY##a5=~D}{dBoRP%@f~f{nD$3VaXO{^MdnL%at!W|5j%P@^PVido}8g$K4L*A5sUP ztwBeecW+zJL)UHwao+K%Q(twf5=hAsSk86Px(%IQuW%9Rd%?f9mcC8jVI4j;HSqsM*Zi%ii4) zpb!{@VZBxYfvOJjb)(*B?6Nz8pSU|v8u^Odfr817yF$*{-U9FR9W8)~MBIbPr!&YRJv z7yjDFk~v!65*VHhHFp$<&RZjphwy@J9)K!ycS(w~=>L@inl-6ZmgLt)+L4P3%6MMlVwKoh`l{4)l{%kP?Y8P$=c158RY}Yx47a1j)?O6Ws4AXb z{Px4R_!vVMUzM7!!o2`-uQSA&wH*)(jpjKp1xhLE4SiT7D#fnsI+h(AD5egT)z|bR zR%czS2X$rp&g|K{Tu`~0YuLV3s2ZMwa0M}*V4N4YctN4otiHsnpv>b-n(TJ*GQxvF>a`SMwJbpG*@7jD%aUD)}@gW{@lRSv46 zaM{8OH|_3tJRIdw(f@_onHp9Jep;U#Bx>nIYcLt{z@YVHQ~Xjh;c*8e?#zMIzhub}#EK(BsJpi2P&{%HnVfldGq^qq}>}+3c24SrU z-R^$+&TxXhYNTAyUm@k#!8(x3t&OJ4A?0|&I=IWNiKaoxe~i%#52=U4TD_S=3oX}z`VmOq z{joJ%aSQoQZ{%Prq9K@>e+Kip#&k?fitVb zR(=b_{3N4x&?IV6C9;uY^@n5%uOYcjtb!N9*C~&UKAPYvDupB2O+^2HwXYRFqqN;MQId(I{w0q>bPvwH>^&ooHYGXnheXr_tVlHFn zvZ_CmpBZ5#r9O99K zR|Ona9Dbd_FW5vBHjty;h{6kwj0fxef?If@%)l6m^+klaAI0!goD8oAo$(8bE*P3{ zvog-yvD~6jEIeR45g;(K0|aXK9Tgfd$_@<}rH2Nb%Up@yJtm+UV}Uy_M}M0bfYDz! z2HXa5 zeFJDF>)*WxOuQpR%xHyS%!1>9@Vm#T>^=zLNF4Yp*U!75=dG#UrX0fMC!kN9WaAL9G5H|AfFyu~Vb0KvrbaDq@Wu`W=u97N?l6bo>pokq| zDEt-d=#4@>U@Sxgp?)9azz0MEs5sUrABx3tBS4^X*3wE>{VNiss%A%`N);OI}@tD^#1Z7FsJ@NQ|e$Y#${{8lKQ6`;$jnGDV$j1Bu8-HtW z3E8NVge(450vdO9?PTPRv_fF6pa{H;ku2j}QxQ#XnOcrA^&Djyb{Vp;C(AUQcIw_T z2TmD(JBLnRfw#<&dl2j^gQD2Bz5)l%p?A!I1?O@Qdf^k;a1KKMcpNx4YThyi&gB4z zn751tXFSCaP8`n2GO0MxE+Z*zNSyo1SeJeaUMkWi%OsIDS*Dhwog~sG%OsIDStg0J z$udc#O_oU_ZL&-fX%l5UNSiE^MA~GTB+@3!B#|~*CW*AkGD)OOmPsP**F}>2p{V9B z^9$8fkvyp8U5gm19epQM^UghnYK>f|mLtTb7xTQ3jbWaD6>B-l)N_<^G0%^kKL+!> zE5w-hCh$96|3J(O8{3Io*zjYg1LtOS3+AQw)lBxa1Lma$5&fYw&yT@7)4cj&4$Skn zvpeQ_=?7!pmN=(g1oRHwMZmyMj%;w38-B!bz(!&J;vkgqBas8}lroJReKnJP zFz}bz83R)YFJWLcP7IUxDSsFait`J(U`A-#KV1v< zW6fVu3pTMjUwj{&`!BY*WCZQabVB_*@Z-Ml^WsOd&^4w|*Y zZDdlH`FgzE7GwVxV*axb^QZG~3KdU<3|iKk!n%dKGlB;3D-<3C4dUVZJO~Pt*ovTO z?fhwWp7_mH8$p9VNy9E528UZU?8D&bduZ6@!|Ksi4O{i~b?6Dp`3pUN0R4;`fPUd< zE*z!$Dd`rrvGTx=9&UK!Jg3us^l-qEVn=jPG01Z|?H|w1s2KRgm?K?=qAF}hKmV9r z^z(}`?x~D_8@i`5{_W$UU$E5(nc7z~+1GaT%b%CxhYFLwoWSB`{wX$~tlS?z83}*6 zhsDeMQ!GFJ^eVrQ?H97iuD&<2WhI~a#dQBhDEPgY?pB|$)V`X@zP<_t&wiocKN|&q zuH0v*QTfGmGtkXn=GR>l?kX?3rR9tHq3Gtfne2>i{$+`wo8L6IGrIYAxVEcsNZ0R$ zZd<)wzaMq0`Q^YL#b9$L*ZGmySNE^v?!+#SRquPbTxVGIhUxK|zZwCzdl!B;1WYmh z{V)XdBpLd}TL0pb+}~55b#nsMc25ZOL-Ep&D=uEeCSK;B;Gnfzn#;d8YW~-num3wy zb9KSoRbUO4y{^d$UVTJp94*5y=m{+i>DH-}ZxkJ_W5Hqhk2 zyc{>vQ_Adq>h@3elKC5}8C!DPy2)eh6t|q?RwcQ`#?OXgG6am)IcOu5s+I@fO;sCI z5!penzV6Dmm`bcG3P5)!P?dwQmc(fvf1$??w1R(dXY^YWQFsw_Mf8(ly>WWNU6Wteb-pV=zvXd>`Y(5iPAXkkgv-J3W{{Te7C!Ji z*5Iq|h*G!#;1N)J^f92X^eVmSr}c6{qaIZ*D(BM${49x!*#@(^Jv~2C3b)?$?Q%8U zEHMjSaCA@;7tae3gt8p~!Sv~AHpOhE;>CFRNO=N#v*~&x#{c(ux|*%AvA2)259=2t z_=>5b?q+4q{0r?FFT*zG_gX!3Izt%LOU!8a^z=Bto6@7@gP4jnWtNmR&X>>Y+56?= zJ!V71 zCl+@HEk4a3A2Ac%oq_}<(^E^#pa0BOOVz=eJIC~in4%9_-@IQfpWnR~{fh1o$wJ?4 zgJpZOk%k~lwP43~fYx9PUbM80d0zttscBpniY44t*H`#!xDYS`-UI+6c!|Tt49jZ^ z5+4DY%axn+jhCJPO@uiCbB$QV$L;48rZ_3@^uoZ)pvRx$Y%iy*?lcz!;o}C?H*%MnDp<^G=Pe-?}ZR@m&;)r8cMP#FVyN z$d&)iu%R~1yNZxh0}rbPqWp2;${z<#VP;Q+N~mcJx-Z*3=he6m&uzHwQQ_j=UKoc$ zEdvVF4E(b%Bn;eUYFmZ}mD|0&@$aKaVcah!pkxit0T)#)$7TeK{#e*G$|7FEdU@=; zWSBMxr1h#ZV2w%=k6Kq(z1JQbf)VckW94e4B(>g3e3~b$P&>11 z?lQ}!J4fJ4Lz;Rv8;?CF)R$|TTR`C4{PO95YtN!-P!v|fpwqG;=YXe$;YLjcJZhytZ{ z0fq(2hWvU(UyJdre!yEju=$k!&|XLWBVk$6VH>h_zNB+N<*qmV0F2h zQPYPh$d3aH38Bg)D&yR{ zdp2shWkGg9m7U699ktEvLdfgFthJ{e;U5iX=VeX5gw7Ig>-e_j#ff$y3X6L&eCF{S zRYjD>b%f1$pp9CQ2w0TB5IwjWg9+asRn1E;bOoiHeKdtP&fcI&gA{oiM_y-gp*^zQEY z!}FuIs;!ov*2;iIso+`7kC|M$pQm@5$1jvgel>shep7yrCX4m_UK>d;dHihkVZH(N zs*-L3ZNs-SQW-l(TWq2L3pR@47ikr}?7qg!%VSv5>k+W{Q&tv0kLk8R02u#%-5Pbr zjscY|oh1}oim2Pb{%1o<(2rwv?3MU0z{J}{PEhq2; z1Z-OP0z4|67of-){u2RlH3sm>djQ$``R!`?yqN=B*SOMXIC+F$(^blfqg_;5H)K0m z#n7Ypv;;4N1Ch!Vk1h&ev=fnJz$zdHY2S zWV5m%*cJNCiR$sBL{=_%F?|bDecsGKQGT4Qri(l10rd9|v(0RUn@6_t>HTs&18gSK z3L56tcdPkZG+@mhm!IU&p#3{&?1Qnjz_3o#gl10w3pB_ir$$=`YTv_L=8LD?^g8tUaw~&-csn z98D;&Ffj9093TdnALc6nqqbpjm(%BWXa!Nk>N5~gaYFX4scc3)ABlF62^m^GfnIIq zPmf>lXS%r+jbEGhvLT5SbLee#N7g1p<`&wUp5NZjr|*^vAcmGH-Cm}VfR&LAk;xqq zcMipp71z-9`r%8~>VeihDn!8fifB-fKlgzZ?gv08GHOO7Xm`f(z0h1CpAAB z6#77t?1h=x>q5&aEy%bR5kT)|E6uNfQNZ+IMGzbdvQWx~V7>M90jM8nr;Qk|W}ok7 zXe4W0BP2ge-!0~w=lfX&dtd0q)d&g|Kg<{N56>S&_xbJ-P!LA)I9t5iyhrR*25yM} zI1)l9*$j%$=Z{}B;$Y`f*pdnx z7Jy(SXy)!c?Be1iJx!}ViT(w@?c=?&p`iHXvKy- zxRm>|dj)*2fF0uiZ$Oa0BddfuQdX~ky#Qhg+IuujG;QKUaVZcGK%%BkKw@CL)6EPx zxLRP@5cIUCJ8H%7h9LFfd5x?B(4DNMIA1cmuI1SuE|J_mclh!V2x>)%4`0V3D@;!m z-65$$o)uXrG!-k{*A5Am10haFqg1H(G`*X-lS8t%nrR}g7!WfCmhq<6ev1ZI*ON+x zNC=56D6NQ(Fn`3AHI{V+7+tef*h7ma0s^+C>Yh#4{0@daN8yYPcdTPH=Afw?UgBp< ziEn;^fw@Qe5!ys;FSE!*b~Q(qt=r&Ce$+(PEEMxe5222vkoX+wUq7{pE>Lgiu8*Y# zh$VeA$_!k=lE%C8pTyw@3NMzhxz;EQGo~;~0IvMOJd2u0Z2%VFeohr}z%YP5lO!e= zGZJ8Cs}-GVD*JVTmKU*GHiE}BWO8C`jFDfM4Kl6N6Gi+iSDW`sCbsu8q)E#)j|v4h zYURW951`P?)D~7V67EnVkmQ_E4o6#&LqywNHMIq|4zFecQ#GQdHe-o^+c7n@l@l}O zZYA`NjgGyZ-#(@f1y%xu$R{L|C@f?merhYQ)P%{cTjsT9y@SNKGPVp1cg85sqehe` z4~H-III;Cb<`MxP!EJgsUC;Q?diwZGR1wCBxI10For9#b$`}dY6mSuF`YhQ7Iz%i# zP;>KpB`2gd!JSGbNj-xwQpu23knEVfwp7>{R9b^h1tE+ESq0*(?VhMZ3(Up6w4I&L6`|IA%kuaR$Kfu=Z@SwfLoD-(|X}S6X(TzA0 zc1E2N-!ToaP&kR=R)2yed}X;5V&-$BK-|i^QleXc+nq$PIrlntUw@{ zuS}x|c9*oeEesb>W%ImR#J8H1YzLs?DaxxG=me*Hc0{jn_thAzzGw1!Xx;PGsAyUyS3dnc($`LDRRI{H)Ttu zOl=`c)uasz%P)16Oah&%>nIE~pip$ee28M8Tx*2)nA*`lINLFBTS^+WK|6ut)mAU~7S?x;IxchTO5<~!lIEsBeZHr{!?4?V+B z{)h>8#AtC>VW-3r`lmc0KM3lT6u%hqZ)Jzg5(W?JkI(*G&zPWEZK50H8aNqLkv0!3 z|0KO%ycP6#X+-2Ur~G1SmGJv`(F6@XU!u|6vZL^woF_c7UjZ1g`sDmVRfl0h_0jC< zk@@75HNH+KIz43>&OD<dk86%O2gv7}gZ~e& zCMDhs_$MHToQo6qA02bxKYS#OEdJmpGw2b|PsGb=rBhXQjU28(wPqeyAhTkE56QSUJSW5cimLZx39drj zI+&ullg9vh59!Ap|6>L)Kd%Ozs_k5GiI2@sT3X9Y=MItIx-Jm4hO3|D@s+A2RJuI1 zLf?5I`6F~%>a9EI)P>qAPO(|#OOsyyr8vwp<*@e zCo8^Cih2q6>EgUQFQpKz)?#JiR#2>jb&8p);C1;@>T~eSqIN=qRZe>ct zk*?vL6U)WQ+qr~s_|sub8kyF4QA<-A+n)jUa0jr<18eCsK)cKjpB&rdAZ1wuukHn( z#0R#AU#cvGpX)1PynJrifqC?<`vcMI4$da$=$GFSr$F6_8DzCnsiY1IK3E$jf00#& z-RJNO0r=A(tE51Qy@zM}^rsB0;G!IqdI^ubdNj5za7ME^@TZx%WU1rj7G#T#e^#=Q6bwvRM;hFDYYfz- z3u1P6f`nzz?WCd)09v98g%fU{w+3e*r^4I^-EODbN$DsJTR;T8z_lP$^OwLYg;a`& z*M-^xN9p*`L5D~s4teBDDMLCiYj8%sotlyM&! z<9_hpeQ|;m>O``!pq}D{*vPR0(y)7iWQVR4KnJv8nm!N4q^GdG5aX+EI|6W1xHP?K zT(wg|bqISulEA)9Ay?2HT*LfMIc07_gW*F z&0!ZN5lTTi9j<)ez(TDjE%_G&5mf;lzfO z+}awATCV{DrJ^ITUP@^Sw^gl~`{qdRs-uof?3*L_*u6P|#34k(^%mkgJQ81 zjo~L1bR6pk$Ae&h5K1Rh@}LsyN4!8FmN0_ZdPBanQ+E4QW>lSy=nft)<&)Ko$7A zl?kgoeSGA@ei%7)`))P;fEXDSM9llxxl&?%3TH5k*T&Ond3X2xgfUXcC7j($`qcT| z@=-mYCEX9m{f7KeVjl9!7pQPUPOR*GGDE*Namz~_9|jEMP0?w@INsq^f8`jYg4|3u z&z5&Mxl6OFIfp!YKz{@7mb^5U9&af6VB^O@Y}lWs=mCBQ3$=cDMz4zHTXc@0n^=j; zAyF0$1%;@}6lM*R37 zAVIZWg<{uF_fzF!APHj*_X3Mq_}mM0Bsa^!V9ag>Kv<$%@+|0Ct^&k4@ZTGD8DJh` z3v`34Kr=AMfj}MVyK8ycYIB$myA4BJweLV%bFUj7;4S_8nx9$v5qSi#g8@Ykfez#w z@(iFi7{KEtol2A_ipNVThK~aB7ue0nzNP+wvl#m2F{`c!v4?~3YTcA+iVx#A{kbJ6zE9nZ;9X$U`JtP>nQE5g5E7*ES zLOP`z&TW>PaX?0N_QhXs-zX!y`Lldv3vIE%{HwIX>WnpCCv*k(CB7AiPF}9;U6N=I}Pk?*MSAL z(IfY$;xy73RsRYQZa`s9<<@_lXH=?ldFY9|FLMxtb%#057p#VTMoEVyX$VxafMG!* zqcea)dPNTe*-qQNK0ZY)`J&sV)6s&9c*X1EYDrw9Qd6x6pS?#?A7tq6j=}vx342My zFQBSd<^_s3ahj-GCA9%$56|wpbymbbUC;i4{Wlm+MEe{~1j-cz`Z8EDW*bE`20^fO zh672oLGm=|O7X78EP*7?bjF3y`-1U+8@w4K{*_?c!k;qy>BHQmRRUM|R(f@2+67tW zjK&(1iax?-4i5Fs(N-A12=tKvFo9mtI>GIA0z@t`Sw-bVS;qOX_?H^5pIcz1eUv2k z@ZfgbmKHgDOb&S?X0JWPP(1U^46u?ZfN-=J6}%?J)~~tGo;9_L#Kd;7s@g!86zccm z*X6StjHmgkJK}K90O$yv7Xbe}Z76%WcUCGOOu9FSqHq?mQ;X-4WGNqK1b}fqsR!*D zMsq3sTV9ge+z(|hM_GsLTh7vn_lI%bf0&o||Nf1fKgbZp#dl-f$=6@Q{2E z=Nx;DtYa_h$O~yli6}_Q*_W{|Cqt%DL?^x~y56kF9-b0vAkLIyY<4caE8+LY66RiO){lQ#g4tNR4p)N+KwiIx*y_Iyb-*@_rYkmQ#Q$?gPH^ z%wg$gG7=z%b(zoZJzP*lEKAmQV-e{#yuQ5rkvHDmZMz1L&3qkOr=b)yWkFY!d;9Vb z(AvBvvQKOAg^%tKcqCpSiJ~tA$||wT9&yb9Ew3Ht&^rH9#DvZd5hExOf_kbbRbtGA zo5^0ch!DeXr^&n11sr5ieZ!DX1qU3-8asd?5h+aVh`aYom;&R;``Ps47x8IEhu{T_ zeKA{1AA$Vo&>2N>Gl@YX7Ey^A!S@NNbfZEl0Y|Z-Dc$HGMEC4E;E(qr8v#}XoM=$$ z;g6KqM>-rDbOjsglp-h0z4z?z=j*%YH612C&NkwC&Ec?+(e_a&lRI*TfrV~-4aA}) z-B65~N<2~uzQBukz826`ArS(_`6OWF#GBFt%OW}%x10*VoIL2NU$+oh{q-V6&6_x;qCGzL+=Xqh%c7tztghy?lc$pq1YBl>X zMcWXL!w}7s&Ey z!`?Kh>3O0D6De=LHguXd5rqa^Vz`?}UuBDiJj|w>XC~MiKO)Gn2gT!n2#fW*QcXdg zAu`%ebKtmU=5xur|3Gd%hm9m%8E~02+jTzgfGa*x7z+w(Dx-uvEFT}2pRg8s1Ni#~ zq5RVK9K=Db)HyBFqeg;JTey!rCY3CLgSZW)(5KZH0Nn){dWwA-G z^Wnrp68?+X=M687UKzwWf1DS+{E|vy7|JJ=H|P_RS}l_K_oDc)T&ev)1Ld$36myH> zDEg{Vpe>x>F}pZv=&X6sFb|ww@?>=t0Y%4WyJtcmBch1M=@$^!Qjpd~__ajWwU62Z zAv2o^hYK4FHwaFX!=7ot8=xntc|~^`7LQ?m(8?dPFKSUGDPgc>Rjw6}2`H~xJy6>U zw6KgV50a;5HNtI$OjMVLZK)?*Y4w&3TXoJ)@&mRUg zBG#$9CxvRi;w_?x14Sw2y|Ccmh96mXBIf2NQ!SUk5SQeQSj7+R35>sNvB+d2#30|# z9-la=8b*iaIJ5Hwhq}XPcxptx20nTw!f_oz(w|}=Kfr^T$KO+6%)c*7Nir0Ve4JBs zQ)teRGhfx~1qOS1x0wHjgcdah#V6+P7O)!k>0%2Ie-q48Et(x3P=@FJ;)eZo+j!75 z6{C?(d0H^g3^YY@Q*k*f6suRQz}=U-M-xcaR~5j8-i^%9?d`&%4aOyZUTiWF^%?%A zry$1;KtPF3J4`0)-T*H_CMpRP^~5oc*J1!`MhK|U&MVx**kvGdV9XQ)Tk#G{USj`G zFFA(~CtM#_QeFcl95>SyX)y+UWG02T1%<$L#jzb>L4N`VOd7y#Ew>z>yYpFA9(kQ_>zwB)X<7 zD2cW*_#%TR1Hy+H5N6L{6Xw?m$7u!n#PDW*%+d;t;V_)*Yt-#sjZ{Etm5|dL>rfIz zV2kSy=;Mx1gh$*$NowAhRu<#4mA#6S%pm?iVtu9#dMS ziweIi%XTClV$jUH7_(yakW zo(M<0RveQ7hK-&WhE%8hwC9HGO3pBl=fscueYYZ#v} zTy+Y&&(@8FZFm~&*NpndN*_Lgy|1U>Ww%BxJ`e?$=_)P=%3X>!@fa1{0&*Tr_?^wMZ6eJaN~}7kz~g7M4dV~u;~!81aKm^@ zIsz;5Obi(QS>pAtd#90*gZruo%&N8wq)SCq7+v|pOT=Opa1Oq0WeaC>^ar4mQZ-AZ zgfv`xLTVxlP;QvI*giQvTk&H3{O~Zpnb|^LmVu~w$=B@j?2fPXXV11B7<-4y)M;@m0#}opgK%fmSDVQsL zzp8X`UZ00AQTRiWW?!_;N^ybtKtzA~x#FI!$V~O@9PyZPMrl5^y~3c}D;A}}2~B(h z_E4Ehn!1!})8G%A+l}gQ=(jo&?c$M9V zi*$TtnKvfIgGY4DUXM_SYcj(TVWpenD{VA|={?M7IN75xC$_8`+1Afg`=9w(hD?Kq zDu%ps3H};oO0+$_TUdg`jUzKy#y~}2>C;M{0XxD5uBC$G#>q?Qd@wK&Fo;S_7LvWR zbpE(9ZO;3z>tlc5i}z2CUCPhP6Yw9g@A2J|RJjx-C_6JIEt;lJz5op(-Px~%A?cT^ zjTpBEor8mNwb2MmVhpX!r=E6t)3+c~0P=!#RuUJ_iy3AbI7|vu+h#phK81Sj>y*ip z*HnHF$g=Q_8&!(6c=rs#m^)r{TwdD>|`zeBbUb3WRA&VTkw_oo0$O#Fcc zk}KY@AN*t@1f3!{Iz(OJ>8T=)08D{rmF@ZQX}=AEl9+s2#uhk*zvf?H0At(dG&I4) zCeu4+N$6i>PjYSbl^mbo{oKt3X*r?nUQHl*|9emHaC> z+qO4ghwba0BO!>=7GxLFZyk1zz2GU^2l}U? z13Zj*)cyTB8g)A_5|Gb1X6}Uo?8-|!bVDv0+gFDo3R`mmTaFdCe}_z$bNjqB>Cb6tUx-?n%k(QJzbD43A!*c!2(59`!=~tyc84!SCw2 zRHLXCI{gkD=0ZnA8u&0JRYLhid1bG$|yf=)5MnyHg` zZ*{~gQGohi_+rkK`rf>!qja5<+~{g+&;n=56-3RQlDR&wp6I&E^1+TP!w0DoNlBjR#9F=5U(^g{Db5uOGlbzkq&>m;Z$s)poU_3%fnxQL+X+(G= zn9_vz3Lt(|ITtQB$&=S_UL>-+$BqWvUeA9JX3&B2bfwQHvJ#`p%N`4^7Y3f*(v3F9*?1xo&dxNRPM@A0xeuKH`3&!O z+E@^Sf;+W0D7qq(N=(nSV6>puRurD<Xeeb+e5u|rs!R!4uq77| zY6FFH%e2$6BCNh4`k(~z+X-mJAWY=mckT`|y=85+v`yumZ)_mgX&k83ik?F(EG;c% z3I1N4)1UG0@Gtdx(i`4f!)Q)o!O1#9SeP0HvX%a~-4;WaV%bubThtNzg$BY|=DEG0 zCg0exa^Jj(4-{vt8jq+#G#>U47f20(KbYWh!f&|63#-A4_7K#b3n+QneQh!Tqgk*u zo|NcL3CHq9^nta6f1_9M54|w$3`l1hU`QGGGl}|LWuODBj@r2V99p;A8lS-M$i4?i z7fomYp!sNEQ#4)$Cn_gj$k-5Q7<^fojIO(t9C3H0zNOU#P!)jX{AcDw!QkepOXWmt z4k~qi`sr#jM`sCA&9aG6V%lnz>53oz6dgA`fZl(L-XqW@4 zp&p?L#rmlu(I^dMsSc6dtGv2RjFWsUf=Z`cPaQToS&Qc<=|h+?cHUtaAF*}qT<}*d z#UzV(OUCCJpUm%P?8`2TS7KHWihWi91clL8O9KAukcG)a*ndFP@9pw=!MswEPI^oF7Mgp>%rrvRy|@*fwu5(`We>+)Y((YA}> z4z^o7KeHKpCuE*cgwR552DcfluO2?-N%Rwq_GVS2?gxq zEBu+d6UDBmD!y$$iX1p8i4FxOFb|pZ;B3r86}!Hg*x-Z}6iG9QfhMY$D4+m`xjuzN zLLO}3gr%1NxXR>GD4$sTRW1jJPxk5JgcI{hCpiBRBnd&{SSME_gMB|5z)*XJbF?Yj z#!TM4kZjMW_e-CR$n{G!FsgZAbR)ME3AwR7iWL$m$|If{OTHM1xnnjoORMk}T8*q^ zxF;%fo7Ks{31%tPo@3d>OSwPxKqfG-7%r4VwZ_{lckk)e60ql2t=rjJ-iPjphsPy3 zN|)5tLX@Rs6Lf7EIQ{IiykWGWBYtG03C}aWtz1%K-pBd!dHtvw;w&iYPP3)CeV}^` z=(Y{&BWB)tK#@gz-&yw96?z2BO6qnl$Q%#PD{?uPm#dus7Tmm9Pz^Ce8L4WpsKyc@ zP?LoGp@f~dO$nzTvl2;by74-aw#_fb#EACawLPHm?-(wXhGLScJ3(BXfT4Ij*)~|x z1^4O4`J;;21cNd5Qp-v*dj#kj<7XvK=_90y{jP^sO=y7Q-<^k~0=bbmyRf$t6_F)* zD+X~Ir+>0i94Vfq>+#TW8(|Z_aqQRxAyUF`%zDbcqp%lLZ8XyW(|7wZHGo>04NID%b@r-G zU1Nu;=0MdB^KK*sE9n*Q}v7WJftWxKxNh@w0y|PNziV5tNf#S5sCvzkB zjBve~Jy}-vYuJg81s;i&}W%aBq^Vw9$g;m`^84j-(e1l ztW$VLz6+iF3*H?H8O&L1$jnA|zOoy|o08d}vOw7GVU&W? z|033xrKB1UeVpKtvQDg2TM|o1u%FKExqbliJXEK6-bN6b6x4769 zR)tj%Z-J0F0_fE_3dEs76Q+m>bxr1Yr!=_xu$wHVh8Xk)gY!EXY!S9^-te_NuMq_0 zL(G8jvVi}V-@Hj?z?$IkF^$oW#&u^M{QN zyMvGS1ML|!kP@i{r`ZFZla4=4pPZ(2G!8somo{Q~dlG%GK#87xv>ig8pFk`S=d<;C zwgCFWaU}JT2Jl?pp0t7e2$~zQ;AB%q0a?v#*PP$_7FQngdngSpjO9197L2oGQWRxE*5DX!Mfu=J6{u|@nw$3HLvoSXeQ}9q08yJn#n%8*#Vg5+B zapcr^ml;o;OlaR0G^hjhtLXC0TkhE9-pcyLf1Np^(4j<+z}+$q`lMnSXQf4dKl`?m zg}Ux~KxZt7?DO6!Ym=N@4{0~!^+?bM=DV!Xqor3l9?NF{8hV-}mHc^wdT4YNAPPk& ztEz1r6PjdCH`pS`C>aKMYq6Z8aLhT#<_L9KAJMw8h~(3qoR8{Rok9B&;;1q{VJ&4? zl;EsYz$tF=|j4xT>U9#ZUlKF@A*Ilv{*vf-|o7NQ#od+Hp zcHrX;vATg?1txd)l6X$F6rtBcOqNh@OtG{=UfRtc;54FxkaM=z$f^;&;Yw?gIDUifKy!Ow9LN8SA4+_MbG zJ%-)hUicD?b*MQOCavo|HqznqG!iIwqJm<_#rFaFTi0LYLjjQo3w+~CL4@tYvM?nR z7laQTgx?4vzK!OIZy|dk59Jd%iJ$P$zf=&Wt(a#QC7z%Z7)fhNSW8s`#%u=RpfW0< z!rgMFLP@RlS%y+L*Rzcq$z3U>9KPd=igNOHrsF+HfAvq(FH&0uqHgM|5P9TA7O_c& zgNmq@OGxA~p8{QA0k-hGxL-b4!E#h+D$F5cN3iG(r6o^V{j z4(nBA#qjIcNFAi^V2ms>e>|lK59?c1Y-RNbIlUS-Ss4r`6)sV9)6omLZ(Pg8PNwm6 z)rh?t->^oM^dw<(Z;viIx+;~dX^!BytlDUfDx}Y2Q$iBq*|_u#pxA0_v6!J-!_@XD z6voUeQNO8ymwt+x;6LdG6!K~h4^xTo=^Xas1$%%H`J#%)=(WsI z(aDsqj9r>uS~OJ0oSiT3&>!@j7G9Y0t!4n-nJ;#jX#Ufej0?#~ zK2^sljv-#us#yy|;uFpiWwaZQabH4^d!UjDWR)-dcH~+$&31%6L(Mo{##1eaF>aE` zr&$LY5@Vot5EK1{cvcccPlBIq#7Kc?jSWLr>qdYfgO5vgX>Ijwu=$zzq| z%$y0YWwH7@Q{?oDP+GbcD57}X9Nz0ZUmc}k)_p=qtv=O(#!ls_y|IhS}@(r+A zm`8|ab_^sc`?CYGSx2b%GxCC1E9av$3*5fn0+)1$CFTVJe3XKPHbL&o(@LzvBpH8l z%>+%haR9z^rFaQ`>LXGyv#O`M^Tsls-dLV$PDwqS7;R4w<`I(%xe^Reb*yDwSEC!Y z9!t7u$ed;4^#Z+$aUx!m-j4ketP#+P*y-*C!r>xrJr&a9YWYMbim(w0m2rH)p%Af4 zjP>TUk38Sdg5b0wtqBxI4qLz-UeO1B&zw?{tqE&wdl1vN%UEI(5K^W89`#W%cf;-N zL9*rh>FS9Oj2>VoIIYN|BjYkAvz?ap14`L8U(jVYyv(_d+a~xt8U&escRx*QX4=_L zh%PODp+${7l2#bUj1!!*c<3yxR|r=yzJC0f=w>gju-S{N^k#)RVgxeTO63mDR4#mq zl$nq(Rj}q2c@oys6tOQ4yGeo{rYC2YZ5&893jmOm#K$N38eZ8txam1n^EO3N6wDN3 zfE4G=P;yxXbZ^-f0lgSuy0S`6F37~*NUC?NW9*v{)DPrQD1i@Xhnsf(V9QFpDea6$ zbmAo=`&VS*J?V?Y}r(Yv$@|Sd1mOTejkfbhCl7 z&f_;BpCh6_3%~AfRmtDxiEm)_B4O9LvENEn8{VO1J8W z*AvYT57G!>@WftCWyXXxVl`8O2&t#C5ad{5id&O(Z8CuN+RB+DFm!-fkXIEQ)mlFG zI(#9pvz3g;A6qq#)=Go76jy9|C(V^Okfppr139!;s+Fdk+6Fdk&R-7SY|~;Bs=TYk zCNz7A){g6q@bCa_s_}1-jH6-^KP^rho9+T}1Fy@FgPt}D9k~}v_`AGx(lpvgcW3{} zitP_6TX~@ShgL-EvE__dk{*npc0&7W6)M=M8Q;ZC5tKKzg?^+XVy*tm5%I@5BG$Zi zQI|K^=#}F3pR`!&G~;y7C@XXd23(*72oF}26vtQ0JdQ&ZaYWxMpkf|f@;nGdAuQn? zb}E9TwimMzo|Db*mZQ;0Xw@3qVRI_uAmMH$H+hsxW=#D3>6S5MKUC1$*O}=zn|80H z3r_sX2LO4286+^*5oSbmE_T%pJy$a>ejk&3B4>uWKdvf zYECs}>Cv{C+wxJmh?5Y_@@@+k%55l8T(0JGQXI`p;vo$g<6!Sz<#s`H4wF-_boa|uYr z8?z3@;MSOX#E6<_6y&B8v<|bQ*^O}+6wQvl$Y6Gt-Pbq6QD=-{0a{~EV8Npu=@JK`*Q)g6ol)NSEa*OI*J>O{ojXwfB(9bEzja@C6m#M>4!?{dDlo6hfH zlocoiMXoC-YENdLr|VeB)$-l@k~po1iRmjPvYz!h5k1ioV>=TB7wW)HTFswSc(N-U z15dY7E=LOxR?1eczk!`fLE3XjGMQsZNumnY$UC>fbDfeY8QsYo=w_6+IAEMfCAfZ? z-r?p}wjJFk^xwHP-Ms#aZeHi?hLfT*<_pm%D?3)Fa#c~zk?K9(cLG(XbJ}a2VcJaq z@mq}XHG5osauuZB@=mhNu-u@uf82q}tzr)$9y>i|xt2!7b5DnQDTkD7#ac^TnbmSb zVTvTA3eO9jQuYBrhQv!$iw>0YR&j&|PwcVS9OwdZ|0i{@u03zXvqSG1^vGzDjNm_m~UC-~-LDKZ`-R$jZYDGY0+4FR{ zLWK6TLie&uqNOhy4weFh=sk$&5%?-+~o8;kml(i zfik>9STY2q>rHnwRHAa!2f>LJkYl@bUh^Lnu1rau7_ioF=Tcf@TFwDNwO}=o0lI>|Yy%g1W8W8{-j@c~YK`jI+-ra|aAzuPPr@ zleWUac+$NZ9}kF8#5W^d7{##^MFZv?!2h*sywFHxeOSH)6$s-UQ^*K9R+E7)7SK}p z?c?(94@RF#d=$DP@&Ab|?@OLXBk4%j15`7O93SUsCD_)=|H;uv&F9l6*ix70FbZ*A z;X^%Pgh8BFZ)<+1P;`OON;a)!iB{5A_U5>A>vv@o;>|H^jFfj&>-c8>%^nWdU*t6v z*~1aSo*EvYF1W{r9M;`koe+Z2)ZxfXWg)d(x8>7;xM3yT#1lIllwq1hW=-E?%c$csD2}uM7 z`897mfUt2psAj>-PfM~%fsDuZodK3YVI{yE>iQKB3$`$E2V&vZKx|jk+YaN}kAiU? z%+v(c{^SLA3il7{senzfDLYDbwr%+g$VvzGiw>zB`0aI&-?Dt>nwHy3ndRdlEE$t|aFWGq;Wo7A&S?Sn(kjKVr zXU!%vsS!xL;R&e{(>=(r~zmibAVs3=O=ci%SbcXMwUf{VW_!9Tzfd|0jhpwuK({ihg`n@(kEQU1{ul>no)iz$zXCD(u11B?omC3N)2FgK}&YlJA+d zGh@Mfkka+1dv@JxjmkI*9<&{@TMYwrxK4oFT|N07l{b4}fNSuC%d``NZJmq@P@>3Q z-TW)m27Tu+fHcN3H2l(Z$InT{3|~Soj{U!LeGC{>#`mPWIWH}EUGp)z4KC*tVB0Dt zma>+r&RO8M&T!0|4#D$f=Q{a@7Tovd7V6vre6QUhlb=($eGckk+GwREsh(KZ7=V5c zlUUyPCI~h1KnNBu#mWm1x=JeQWH`8mcdrw-dKeY!Uu`zS_n#tA$f|}D0);)+wojJP9qPiahS!y2%v~P@_}3T zF0zfXNX`-qmEFTpf=O^^(b=$6Kx=r=fd3Dxr7+OSh_;8L7{pd^*D_8vanJ>4E4-?= zfj?8aYvh>5$K77HJt3Y{fZh~ur{B&?!R`il%R^ zY7(2=-4|3Hj8cZsY)VM{9?**ohhUw=%K4>N|F%>{z@D%_Gb2(8+;cp9o{OBeD`g*BjEn1e8xAo$& z@3_ehM-!&gOS`3zT1xAuL8Hj-XPY>lr=PEyZDNdJidgGfg{?Pfmo6xeg_2#&$=J^M zEw~B1FfP-rdeU0>&d}rlDC_a{$vEmntE8^TLl5!TMVns~J^gmtDF^;yKnyD0o&Jm4n;rGkC zXY>m<$>Mb}vhd6F;xn25Xf6*b-1OLkB^03M`e?giKx{0q}mmqn$sdT^`~hjG#?Ssxm+69TQ3Z*$HB*mla@ z9NDZrmSx;CChzVfkbgt@w^q^_bpO6dt*cFxen(t_Lznz96LPw8w%7(u*h=`mcJe}h zb8_r_*{yS@tTu!5CZ5(rEl1*Mnck?Bo`PCZ!IZSqs`|M<-Ly(BEi2o3gtg*rl1uN1 z(<(zdwX!F~Haw0`-Fm18Mm5bvzF5v^lO)>8{S4ay=6})};r#6+&}Lwq4LUvm7+9ba zK94Y`v$%i<7Z);_vz5pB1pbGGrWDSm**-nuT+UY5Ml~52cNf}$wQu#>lDcfmv#fC^ zB?FVX?;p#+)C=s=HIplo63^iqw;7#`&}{~@cbd{xGrbeRFNlLt(-@mF`ZZ^pmkS^>roA1g`>%>cC_=;hP(bj0eKq z2`6bCuC6foCS?+o=on^t5)b7TjVJ;%ru|SCv?7dPw&MF`swkG@YsNw?DfMB=_&T50 zBoLT}LE;#rBW-&IufkHsa*yESd~Td*m@+kkgvfZz$xARwAV;0?M4U6js?o5xb47`i z7zV>|ds0#4lG*mGb6yUiW33A%^6`bgldf2#3J_Vq;8AkVA$-)=5M3%q1<(m&gqDC9JeT4cBKoO+6E7F~5XA_=Yf%zoKu62k#5~73GNskNsvxgU1p( z$AXX480=v17yNU}pz?%*53~!tC-1egD*@m~{QUC@e`jr@?hQRHAej_>n0dDdLRL!Rw=ipSxfMB*GLb1@bvBMp(ULjuh1 z6eTJlJAz8*PCjG)c&zS;I50Y!WTIh@P1KvH%WX#{+C*cb6Imr0r&&t?ZoXT($b?*9 zg;I&py3|yrCfZ8Tm@j=%=Q=9hE~~!N#UILL&R~Ei2AOHVgs=v6S0|rorEye-6~Cuoq0G^`ya;-Ln6yCvTxZ*%9285nI>k) zWo)5~F*7lC86@l2#$?}@ED6b4vZV-9mSnGx28FC;$&#|nZ|e6vzw6%LeeQG5dA{eI zzh0lud7saDfBrbjw-_QKWzLPhNbWLoXx=((W~1h6(;lex zi%Q%U@h^_tWt9!5riPyd>BhIDjZ*CoMW6?S<^z=PJj}D#UJkp|X}w(3T*b3Ift6A( z#*|0-9Y1+lbv7=c>PBJn&>ABBMI8N^6;?}1eA`UeU4=NVEsQemc?{aPwwa8v9&!__ zDXgd!THDr^j~|Ghsz^9nC4~%JYT&Jzd5WJIVmmH1lmY5MKtnZ?!W_Lm!&x=6lCxVO z2$T66JCsQe4G4iDL-ch7doycxR9YB^(oFEPXU|vt@Nc!^Mb|8p2Vh;>L|$HI9>tCC z?FC14n$52lk@4mi4w4u9_yT?C!iVI7P1z<_Xvv{OcWgUww_pM4|gcZ z)C4nN=QZ8ez{&a30T1REu+y|JLf(HlChpF~X@@<^sTGxEd0kL0IzM5x`r;)H(~|i) zCt!Q->&D6hi(&GKtG{b)pJG zj%;T2-#P01r2f7(y-utSOr^a@C$eYQ>4!aW^2$(6#AEIDy(_8$MHR)YAp(q@r@|tj z5elJMumWxIapL=PW#yQyIUJ*EvYd&??7ny(g(bn8sSdsFnIuc$SQ^w=Ky zzJ)l$1KyTQf#Uigf}K3AWiL-eHq25A0%Vv&_;ev0i4*~M7v{bb_zw$wh355OtM!J! zBwIT3{Nb9p9jWO-0kOtQP?c7;?G?O1rVXrIf9vl2E9J!NDvE;NbtxiZ&m9VN!q8Sq z?jVhPZ#2brRLPxm^rfASz+1hE&D-p6vgslF?bS7DSl#v!3ocfEu0hNN*&&=WvT2E4 zH)%+1vZo{g&iR@p{&@eaYf6;Hq$$)>WaO3+1C^DUO$u}DX_3ArZo*=#C_%zDuxjWV{?fa zt9olR_w?h^ZfmtdyMFz#gfERxgp`A_MLjZ{$9R!T&b9M@b69x;GS zO3C3&J$Aai=PJ|vYIYnAjbb%+IzNfdg0+p-agB69FHS=;3vGY2TZB|MdEstKxuXyZ zPuCt~TKoJ|W&xl%{^+bUIsJati!TXPCFYb_Sy<{@A^kgP1kTilB@50_C9F?{D--<4 ziP1d^1s~yBj9W>nHd8f|F~MrzX9@i|A(;P@uc;*u?xn13<^|o@LHAR797u2)Ub?CC z-IVaaiTTE(+f6=t@0}wTjn4iU9lItRzBHfQ)SBLv8tNOdW-mi>&A3kv;UFncQ0F1p^w=ct58d+_m(ve90c zSDkX{a?|AA)MMZ3O}!ow*RSP`8`1t*JYb)6s%KEY6O^S54d&|OSKT*hN_BXuqud9m zyg|o}PiGb=#9SUh*1i$4*i!Adx&x1GyvOhTg{U(7g?M9UmHNWpdzr))WZ}=^ znW3f5=3Fv%B10Tm3dvgAza4GrcH9e57SoZCucQXGdee;>I+}lMp;A!BJSSaIrV*(k z4g;%LqU)#5CVgPI`L#xhm}E-!0oCL$Zum2wK`ZZdW4e+IgDZsmi(gufWX>x|1@`s% zXwCKM_iu{HL~Ruq8bVtwqH@&O+z#K{%T+F$V7*8BNxK)4hmRa9 zl#Eets#7$2@#F1Q(CXbrX){M$rI~I_+tP@ABc}r0?aH|BoWxx=eMW?4fn=46cW&`j z4Z&5x&bWvNh!^0Xcz?3;OWK=&v7db9i^Bbd!a};i4r!GT_OW-b${kKuT2MRc0Cx7| zhvIK-o4`9A?VI%$vX5zV#nhNTk2?b{HFJ!AeaO8Q!RNl)ogDk^?5a91->hE37q*iD zyL{jX%Bv|Sl)O}9vy*R2_V3IW8zFUylw;NQc(6&ow){pWC4Rb@JW9eA*!R`B8M^17 zZpNZ6$)^mDR@7`~KLyJ^wHI;AN(`_4wDX-U=ITj>R!pE>yeNP1cxG*zzyp*=dcvT0 zg5f)~k&26NmWr+A%W5^kB~3revZICVXYUFrM@TXMwv60kvgl>1*st64>tWkdT?!Fy zn8t^qN7741=vd4(%#}oep`agx;AN)%z19TKZlTq!#d|8-L{)K7>I^%Drxe94kgKbZ zc#DUG3nz;)uY3q3xDTpCaElt`u!M*78RM$vI20RET{hv87WawjQB$^l(vjh^HtTod zd74{N*SDQvF@o6E6pK4U?JS}mbaqquuU}hze3}8ad`yVX?0ceTDF-DnS~D;D4AAc= zpT|3mY1AgJbt>BC=02CZ(1!{xXN$6lYn#UQ)hEc@LrAV3Yl(b^1~D(M??aRCM;qPK zmq@C%BRzGZC!bsG(G%5Vo3iqDjRZax14m(5O6Q_HYzRtTlqqxSlcjce ziE~bElZS8qZ(mc+E%0QM%ifg*qaVL|$gx+iFcQqL@2I^Rph3By(4Elel_*q|30V{~ zw>|xCKl)Au8ZJKWG#e_yuic+N9^1mGMm=`@+<^4{k~>n($}Y~+*5?&`LKdgz1-U7C zYWY%aTD%tB`ToM(VSiaRJ@OcJe9B8JF%cCX*mAc78fP&J8IJp`r7P^AQrc7-`=t;a zvqgmn?Ad)AZ2l-Z3E%XVX=dypt`s#m4uslj)X$4FW{A8o8$Th+{Dx!LjY;BM#pI&h zy-9YH&6tPtj;Ci61Q~>oQQy!yex9f`=eW=z!jhrnJfz0HMs{l0{gI^8Hr29@i0d7M zda?{RRlk3qb=#Eh(G^Cmun;<913G#U(0@(H?53xQI&=ZfBMty|s{jC|+0f60jy8%2 zKac*fBnMZNx8gN(Ge!XP;Pa!u+R#C&_-#*((O8=kL9gNWy>uJKcb5jE61OSokbO7(4Vn{3fZH)iHt=Rq% z{!h%mE# zkm~J@1Hu8}<@@!wsu!sxwWJn{CzH5OPR2;RR9973m%5hzR3qeTR7mHteRI*Z z2j-x6Y0Gau)jrk8r9bg}mplg33Avk%ms8gdoWPs;#CdkSiE}$~i4#CYsXPY3(=T7X zyu7^BeK(kRxAocl;mgE%a>jptabKS%v$?yAJ$|7>eAOzSKC#X_mp9gVmt0+U+r2(Q z{O!hWQ_wqR|K_4%8=axiv)jWe?VRlHl56+goxA?nCDyswClmMCoixaNwhVA;m1lRp zzzMbL$MwA`G*CD57Q`Wo*?sWh%w2+WaUS5``Rv)dbMMIQ8@chl=Q^3)lY#5|?qcD( z20|Qm7`|^i6YqXD_dSPL?)*=8;=UQu+ZiCpxto!W>jP}W@$ZOjekbR_UA@jagJRE~ z-RUj7ZtgXX*i@m^>!d$+CeECg^9M?-1w7-Z>)C_u_wF@8>=<^~B5G>R=gym|WeVw? zVWn1;dVoK#mh-3C!u=&lQ2`qz4+)$<-319AU9wnCakluUbGw*LmVry2oypQ&u>L|Y z;ysG)Y$S-7k-wyV*qb%Phz^&_|d#?Fwo{g}CI53Hd)@I#`AN1Hx($SeeL%25Eh1G`<`i3rdpd?9RLQfGJyFPFf_Gk+~Zz z=YWuVz{&WP)F*D8?4_$WnqRPm!EjM&RLPw?24=W-QVhf z@WHQLJCdg3*_}&3QXtvpl!1u**Ah?zBxoSQq^c9w@pqR`WHOsQ!HZBDBd{c}S~ZM|*kfs??BCB6OBE0Xy=pa9wQF~vm)IkYkU{-WF`|T6 znWkZhp)4Ar_w7^WZ{Pu(IRM#+9`cz{{xA;Xlg^%+{OfZAf3ueVlbnI5(@eB!X|&l- zv^kJb8pCJzyx)zHKFuZmEWs&ZPjp$pH0>H)A4$ycbz{U|=A$PIOqn1m>c)r)wZ#_S zzp<__Zw5WP3(baCBiz$Xv8@}O5&k>+*xrjbX;ZcFBl0$}`vW0X&;fv)z_0!yaDYn# z*lQ8(Y>OsOlV$Xa1GZd1jio=IO(sAElx>SRt1luxpZV^#RR>e0I@Cc+CeU&YWQH1x zCwGkdDOYnCy`0I@qf`I8sUQf-XgyFy2~b9*K^d*44QVPvKaFw|=`TH4q$8%qtggQ( zRF_C4QRpBY6EzU3!Q^Quq;A?Bs?CgI8jE5#x}61&%5_>^bJ^d3<}!k<3O6A7FYaG8 zx_jlSElHgs)M56kDV3yH-`J0Xssj+d1dW4N!@t6c@FQKd8CGq|Rhx>ct*~lKuG%WC zbu4{GS&7u}H2F+EBFNTGdZ?O6`0I@lzXdM>4S@c%dS%xJTu^l;j(lEuBr1<$l}AcS z0i7gNA$mpvPa_FULm8nIiXIN0(319Y{K7fE2un;f5}-1`FRx;Jw4?^P0>?Rey}2Pv_VCrQ2QW~!f}*VILaS* z9H|wMJgp;N(a6^=lInzbyC1&YSG+w4-ySI59)@oZKNOWDc18j@!#L(L6_ib?C^?3i z&gI}kVWCfd5`_f_hAU>ujxg?E6#yRZmg9h0Y+hzuQCR#v4{1JhmXE`g)htKbQfcUd zDq}PH`)NK0TQDA>;!&e&h_)VdkYPLm1bxs2Xii3*sxftU2p@_u`^5xHj#+Y0!TxkT$k) zW|-$!znX?=oOevag8y5F)g72d8~$wPYf3GZrgXF!O$pm?MOng5;`&m@9f$hT;fe+? zhD1bMLb9JxydqWsorrP%zWu9tZMFwcBSw?8v@WxPV}asjRd7J~qg}yKlS z?&Ru?-2QfHoEqnb-M&0G4g31?5B7g6fe-r&IQCE}z zsnh|KI>QB12-%Z3V%s}a{+c!YjQ>+r96-g?y!fyUXqx02QE-0J(u>Swvt50ceE++zcfVwDDyG?^1QPPet~v zj1|;sJcvdi*DE_zYau&SsLCo;QsI%A`nRPAUyzaCAqb>}cRO(Hxpho8^bCCl& zMZaWztyJjFj&D(vR$1*cR=dhM5Vw7N0&*8Qi32C#F+pUZBxQaW?qBu)y7O5anD`he zWPXc=P*%VKI%;!|oGR4R@O@)1>+?vUzS1*J@gPs^D$pYK{?Z0r@`ehS=AQB~F9|Wk z0oX49u%!(kqNB!sVbxYPocsB3CO*M(8LJ;Sb0#ilPcA=Sh|^Iiq7xg3^qBjqA(U6((91d>kjkf_BfQfCK67^iqkvc?$egu-#GfkmY!phNLNUaVDyg=rZuW|3BXz|;(Bb>Y=v5;+VIRqo z!zoxwEil@jpeN%Im4`7e3Yl5Z5lkt;`l@aPe>bwFd80s@%S$8yW@+gLER@ecN1GII zjlw;J&N(6B8m+BMxW@h(BCfH&F%j1|EGgqoxg5%vR=FJ|L&!DqcbLXuHYXo#NXQkj zX>+eg&Yf&V&K2%KQddbi$7$6#{#VJllT7Yt?v;>pLiuAq6H0v-lzKFB(eIN;Ps=`g z{hfVo(lb~2#Fbm7>5;3Bb-KC5GuL;qPH*+JHL_nLZZl6?H*?BLZQLbI+>{jvf$s-q zSNfcu?FlnGeL_PI93T3aBD?q;R4rpV#W%JONl+68&M0(&RfL=tSSg2^B>R6}WxrEecvwxh7Da)X5)+Z{8hmyjVUxO*|?r>8RMqCnMs!@Qg!)_L&*?WeTCv zbQ{tn;AlO5NV38)i68sd#I&0&k6&4^9Sem2>$Dfl86gC zC)AKoOTe+`LfyP$gtpOKWFU=cuzIM?{=qQ^+|z9CUP8yPyX-bjjt>PLPto9hW*Y+! zlkJ3CVdh9Fo276(%xuvJr@n^4@%JBUa7@@6bu5h3jRTh;_nE+jD0Ex@A$SZGckxlj zKlBXYrV(yqOt+wRuBVyDot=s3cNCvdlA%+Wr65Jl2mH}Uc5;ZH1@Q(K=>~Q-U4eOiI7*B4HoPRB$f(Ks*Tp7YMh9_r%>II0)he!J1#+!YkpB(q}43vJbMqjtl{PT{r z@76u+#SgEwqPoJe3`v z4_ELTIbM6p>LtdzFSN@G4i%C333Mn*npKb1z}az0>uf$N@}tNkH>NP8N)ML8T_e{F zmT%!=&MaCsve2-FIIoGQ(QHFcvWzOHoPwv6g1JU2ii%T-c#Q(Hk&36jlFD%U2;eU_i*e3qYvpXIjtn>;o^hW3-^ZH+DI zW{6bH{c?+`uCz(Uj$gFlo1xE)@Ta1|phAjhej=;9#8Ml!`0h<~qVNjLKAFLCmWbw5 zX;INB%|+sfMhS18hxvwylB=KckC zuP>Sv+xWV1@L5%e9Uo`~FMJoTk+u_6+;-`oidgzST7VH_0`)Mk;sA zS>3(j%hk@Er7P>Jv$ThQwU~E-4h&!+;(nWneDTv6KDDAO+07*CWQGf(L1W= zGPZ<;XpkZExiJ`w28F2_JFMb55mgTix`2f)r$`^puuXT^!p)zuLx??7 zjJC-2jt)@@aKhg;-uMe^S*ta(+HnfedWt$Ze$;G8{6CmakJ0R2v z^Rw$__j<>4q-uxLpEdpZ*3)un-T(5_B=Oqt4KKN=M_0JCCE80jdu_`mGH(res!yGy z=S0$s4mOc?^dJsp9xOa#R`fcRd~_HlAI->ZJ`D4ZDl(dj3j1<}@)@u_?ZYZN>*@T)JyLxK_yShky znA%2(w2h?FYZ58-cj~Y^PZ?-!LK$eqCzm;eZ1}T*mwQtx4)RSZsXqDJ{9aYshJ5Kt zy4R+n*E}twWZKS11BvvMpD1f*+98HLBI3@K6hcR8D!ogNb6KAnTwh#N`n^uqxVbvN zGH<7vX zjAhbG;Q+~OU*6cg0g(AB4Cea*X*)GsZ78@zWV58O@0`bSS<)JX$t*JxS1Q9X7;?fv z>Ee(QXi}twZ>i+kx!H*h_A@h0a!AwZ9@(_6%jb`zps0FeP@R`a2&qbGY3t{oVl=CA26!zrRLUihpzACVd}Fcm7OyP%Gpb}W!f9?AW4#ogA&qFCAy*b;_RJdc zNXUrO0vSP--ZeK$Q&WX%Xl1DuC1c~V#Kx6OYATm98&@NL<4WcNEgvtR8`p?so4i*T zFp4FM_Y}KBG4C}SjQ38d%*$h>_vF3i-X?jkso3U3DZ_isMlOb%>*P!*mZzXLtte8P zheE#OY{SiPuP*vzVvKMKxLt=4PPG*1rj~LbN+Bbx_YoH{Lb(LhSk{snIUgI?2y5x& z<;H?I)!N~(FvQ7{hM`fh%V8-%L4>~S1lO_pnL@g?#~3$&zqKOL=&@{}2RYRGy%HHvnf=s` zrRDxe0-)ijhUm&LjWWb;&M2DpHUAgJ{tt~X@HDzg5Cuq{G4`jn?&_O8^K&nTHpg`8 z#mMldYe`%`rz4wRnZ%AM$6jUHz~x+x z={$?*+B(F+;u(NF=3}+=z2L1*LqmBlFWzK=Nq;5(QR*#4g4v8LrWlBaeq49%V(j{N zB5p5XLX$!al&KTt90@}u>3{&~_``VK#UGyMFq*G!;X;`>7sy1D<~b6v+Y2 zqXhLAQabgXC`Gpv3dm`qxfKYLnSzUUoC%f$UaKVShMagqz07qnSn?81h*F-^93uEv zm)MGu&XTw4`Mx3{r|uFy)HsRX-YVv&6t=;RCUXsWSaKKgY9|(Af@>_~wT?Q@*ouio zfR|nGI_8ugyX23`6MD^6zZa>T-_ zMiqWCME4U-hXAd7oLCC@gv*NzYx_!@dXX%UQgdqJJ3npaY1ZOh*~Zl1@7Yjd4MmxGHT9*<9HVPw(j8p)f0AINpX+){ad7c>3`5G# zAcq`5fFzS=S8>55jTnqwY&m#-i6# z$=6km-G#w#vZM!UctaKRgO`M{pJe&;gaPMsGMT-=AJE3}AC^co4mrC8MF2!^1cTX8 zYfWq>Xz~*ikREaWgc{AL#k(9P?-c`vx3q%gX@F0`y_&R6l$8c>Mnl2{Ob$#KZ4vy) zZQ|aGn_vL+x%co$FG3vR9dfFxHhGBA&N;i#ZL*`LWnIH*yTCN0Fz+IZ&KdKi;{fb84E80$9`8BTRbACy#usPE3`oM}Y+Y+zqnf%@k|%8x zIA*u0F7XJ}^LZB%s;0|H;5|*eF}r&;0~LIv#5JoDucxm^rM2a|RaGk^)j+;bHKPGa zzaq@gI*Nrbr|0Vwu_y#23W(!o_55jnN>*4bmQ$AX0I?kJv##nwMxZH9{L|gUyq{7< zF~*v=%Ubo=WwK($Y~xB<7%I9#R^WZzi)8a|lI0Oo?B2|958+)zw`E4;kghnSTY#0i zNAs3mLCL$IAVffyx~cY0QZElnJqIfkgq zpJUeG1#_g$O3X0}mBn+kXMsy|?D8PMltkk5yYrj}dU<8~7E#bq6nA*K9*Rb2eY*_k z`?xIP#z?{3Kjw~OzH$``2rgXS1&*D*m|DIB*&rNwsnrtgi@x$g<**lDx=Pv7U+7l$ zmDI62sk1MohS3zaQZtsOs@v`(6;%uP3L+r`qGHXISaz{3iR51Ta$8j4msAT7&4&`* zt$ey$#dNpSbZ2uAl;@?B98r$RDZ|?1U>CE3S zC-X^(Yi!{|GMLT9MewADwCgPI@1b`0x=Vg_<}dDKl6l!JtVa+a(3LrPm;pSG(*^ks zus-qB&9qfIwR2Ikt@u;@GhC2F!SWG_&} zO^H$}dqIIQYTfvv{A)k4tip@hVLzF?xSF?05ig!>F?q`-81Z=BBpM1vR0KPTQi>7t zeL{3SK30hcW%9OG8>}I6(e_@PpP^YIKSPpZGYaw4W`o&>eZ?t;Dvc} zR@u=SYj0_)bPib7+|n8+Th6G#6P2tU#>-a4X;sRQv7tR_g**_kRi)+l3k>ol*F_0S zsYDJLSuL`1H)zM2ubacDsp|z_cJVZ|_Ejudizk_IqF|2UTniRYbAQVzLDtUekX}4L zFtfuJ7f-1~4XVZSPKg>;%V;8Luq*Crt%gP(h*jxR@NrTqkwaF}f$i*mn9JZ@Qn~0R zyjXLmOdxGT`=l!4gT_)Xe*#sSNg^>%C!9@H`D~uHng3#R@+WXud(tOjgo6@&7HFKo__27jPx(U6dT?{-s_lX z#IZjv5q*c7$XB>3l+lOWd;Z;m8>H{tSK$f6d`h@u6M1x=(P3ojyn55+lsLE4eZ?iu z&SdHS)9)Yae_ZRC=Y*ntMHqU0BpBaV=K}DKY4xMl{4HbZxF&GPVN(% zyF4>_VO1UqvLeTHP&3>dZj#rOD^#;ANXuVDCH$4bJ(Qi;woRj55Zk5PJ{v#H=D9*- zR}`W}(NkjYqe$ga7CIbU-*oFJZQIn{mO5uTQ}h!J0t9$L+7{FXDSkHrJTM>Mv9r+I z_uA^nlD4IOY*GZZg@-5i6@{H?;-W~OJ7emg#{7lHv*{E1cW%qQP*V=~a2ople38~O zFhMaKSjKC2P@jy-!J0rr2- zF5mM&lcB2v#-q1ECI+O(MxY#c<4F0XVB^xq`B!%SBW0qxS-1oq5ZH}bxRm3Q9did( z9P=wT`|Vy2n8-&m-njwjJh19u(O%6#p9!69$B*cMY2b^OM{oSdh6-8NVfq*I!oT$b za*Xj3q2nt9%iO7k9fw_pT{J-DU|q|s?<|yk0JvSN-2syGe&pnE12aTL+pI>9t?02O z`3nMNDE^ROC)`;oe9&k%(;F+pnG^@K%PGJi=Qzdv2o+1}YR_X0!l*PNA}nzIB8Ae~ zCvYb9@7?;zQFwnSJOGV>0wv~&|Lnr&eY&xgY;4JmE!Nm#jl<6<;rte2pxJ6AadLQ) z#tA1!Hd1(njbWwHJV~OZbwnX$4MO+Fu)+R8vcW+sx4~gE*#KuQBmOfv+|NLK3_dF# zJ}U*El@Fhlg3prS3u#N?%b{)KI6>Ry!Co=H8;WI|xdftao+e9J=FMXT`L(IuY$l0F zA=X?BvDTK{I=&h>zGOv7NOn2|mF-wP#FF}uf;+dT)hj8qo_m3k{ycSU`vdynE;%)HzQl0n^$K0OrW3Mk=~;T z95IlEArjigYvD%j_(>;w=o-g?4m=6t(S3EtEK+9? z@HCGwyuS!=Y|sv-&KrgZVJy&`eVxDIK?1_vA6#BxCdz&kuP7u9ybEvB@YB zs$q0xB*T%gBcQ1l@Ngq`e8eysA)5!9MGq#Ph$P}|L?n_N3-sd@*|3~`7s?13 zWC!OK^zpu+?1FJRYx~D_Z_urfnnAu@U_8YM6jEhmsgTAmqHiI4@N~-Ht47Ev;2Zow zn|`~zzAy(BvO{XMFbWJm0Co&w8t^zmFF#g;7riFFd35gJ2kZ2ISl2taCVD4vn z$5U<6Yo{-FP7YrVdi`$vea&o5am}Gwqd#mu={Fo(mraKlm6iejC2QJJ1;vwbm8^gXKjSoebwF_q#vy- zuv=SQb#3qCOS<28M9RHv+}rTQ9bS)z z_Grr7cVHsH+RELFFlAEI=l2hP=n98u90r^=qEPti4ELi;NLA9xC<^s|Ld8?(GsR{y5AmjcLSF3Q@_8T z5E$s=n)wMBLkIuUh5xsSTfkh7PJRHS8s?Qf(04e|h&fE`r^AyMz+m9N?{{!%NAUI9 zgE}FDXgM5dkn~BW^&`ybRl)qH8orDlSfH=qzsWVGMZu-TFFYA7kcA_W_p?8J1UZaW z_a6K;EkxC=01p4lRE$KiHowY2q(vFlOwU13Hre=MN|H8_O@4k}3=4Q%995!P;YmCx`^9O`EPJe^!L&E`hyNz=4JSRda`rdPN?^WrLx7UXI%o)>RH7s=*% zav8E2C@ZsUc56oP_N2s**DXtr6o{kQbeQKOSl<%&0$*tF9>4)X%*^g|a-Prf37qE| zfBZ%3Nxg}W043!&=I80`4gB_V17W>9g_*Z!pe%v5)!J;BCm=RloM8V{@oD?Riu-kzn4(jF%j!`z2 zQ&e6S=kt67gfJfS&Q`WY5X)w;DAOConhqYlv6z77eF>WQ>;nMfZH}iSw?{41_VaiC4&shlP|2;b^rEuYD)fCCy2*=+%Q>4L@^{xT zi!vI~jbSpRKmhla(7QTAQu59z!VXtLC+XIK7FUra;V;BdmsZfrXEQ+Te4GJK%F1#& zM7}p-lK1Hv?Iso%Isk&x!HOeB*8z=S;lMS3#Hb{`u>pd>>0$^|fSV!&MXY?I6+Do? z1J-NDsx7XO7Up#6jHfp^pWuN}QO+~qsC9<539#sr<%Sbi7Nh(QFrIqrVWMq- z`*T+0rConI6GADv^yZ&%C-Jf?mo}{p!pLXI9k_wYIh-&+vMk^#$_e)tuEStDHRo^> z_{W^i!lazf7Q;CZPjK;=TG7m#aA%nBkal<#TDS`RX?ok(rX{Z(z-#)_V?p%1m;rXd z4T5ZHG=sTVB4q zcOseMW6F`e0iDA9JdMHt25(`}aPi8Fp{zLA4tN4rdfwuhdJhKV zAy%FFm19)bqiSsj_+PJwkCXr41y?R{wisRHb5OOfug3+8Qlgc)F_h_NmW>BPzzxhW zl`Ew0oL~$winxuQmo|kjOu974VVAbgFKqNKRMNnJ*<;A+&@ABKZ}* zp2M{@98XL94HoVa#zNY(qv1uG!|f$k`3>kfc&P#%4-4AI8Yse`yx&|Ffbq?AF&^PN zps0~P<{wVbdqENf>2m~2JjrJu%&5FatMnL;=5lG-z*^(4*`my2=hi8WmZPeU z6Fke$aTn$&*^qnz)CX&1fuH3fz@e(ppU!h8lzWIUSJ|y6`7mW)fFcYUXC%>lP1u{O z90=oOsJ0Eyrs_l^(F6X+6F?iQvQP9IU=!2qAGQ!u{W;PVvj zvQ8vqYHoL#(7)Ada+&GUoM#1Ul`P`YMw-!Lrue`l{}b4Te~j3|6%Na?J`n9x7ZTGtgK)YwDdZu$| zw6=ODY@o6#v9GQ(M=Vi98qRSqNpEL;SGH)$)iD)wTXVfQRXBb9JSTQIC+3kd&H*Yh zPS!jlP%3f{X^?!s_ld`eNZ6ne95~|Ka2Joq0?E56+{BkzL>P?{FcKNaS*`^fU)Xrz zGjk@qlv4^$gx}c|R4TVV2-iXLOjy&aVh*@9V6oxw$Z=L9j*H^J_p4SEMM?}Z2yd3p z7qbami};;KC+NBoLOHlEp{%hZA)T;5wvJHT)V=+juc0kxx{Ilz3hQ7!ZNSA+rGdb1 zh0ADZW{v$Sf-Z1sfgr6DspHsm?Ra*)Y?T$y9#6bqtE=B67R{8{Fh!smph?JE2A!d! z$Ta0z(oNE)p3XI7xtbtRVhHSuM1xhyLa$tr6FhFTgTnB62GX(~ON3dFxv#iDQ}Ex) zUuN@v{q1V;E1XzZAp^g{JD?=wr85!(Po9jX=jS?<(i4yeuxj*i7#6w5NQ1XZL9`vC z;`|(Mv|BUIOZtpuA)GP`Eqcg7qWfjRAVvg6SBK!>^B1rJD7X-iM)eVLejFmKvR(a325m~vG&n2vPi z;rUIw^Y);VLdJ-N(TQ$$q+pyWnEc%}GIXTt(|k^k^CY%67&;02s9L22;gUrSy`(NC zbbG6*h@@19M&>WE&q(Zu&6YB8Hx`iqYs9UM|E;_~raMRA9JNvPq!5uWCgNK1mZP@$ z2nnQaX&o-#+4M?T$mBLyJLkG6{ks=VGH#mB_RHKs^n{LbPODmxixR8b0HK|^6bt-S z`9kbOdg#I#t8Yg1TZ#publeoj$PDmC zDv1paxWJ%+jK>lhJ0&@Mat;HamN}hXyKPu)?wsS zVc_FF3CdD#f4u=e=;Ob^C2xqMZ9dDd^0C?xP^Ew5TXJL+zLT#rp#Jgn0y!^lOWCMi z2=>0a#q$eWw$RWCB4zxVLNeHm9DuX>h}?!b+ip~JMS&#AT--cs zgmXQSgw1wyuf2cTZPpv8OX_ewo!n&OH>EespGR3y-aZ;$lApNwX94FgeE`{VA^CK0 z@)AD8J!WYDgdsR+0tMui=@qQR2ye&5L~hW~Xc@Y&iqhys29U^5qWpAb4^72ZiAV6w zWO_4E%?gDGcz-wsK@LQmk*e+-KJz|X#s-dTIFBz@f5%iVo{YS$9$x0dH?)PL1&W4v zKv1FdWhgKC3|G5IS&)YovE;}*i=6YPq;sEN*)TN5WE{(Us?q;I=fz9?53XZsE8 zeExkIA%}NF$%jTIa(^2uD}Z8p0lX%Ir3PM^10sYX2j`4|QgbT+k$3}aVoEU>-f?3( zzM8_igLnY?>Nv+pju0~|K9^RqScMp$6ft^P0Ud??V(3I(SRD|bCiCL_79&;4X(JQ} z99{B#EmVJlbFiX>UMxU*sBROlxS4vkpHnZ@12^`3F&XluKPq4u=Cm3TU^QYw-`Q`I z@?cGGozCH)frhJtAK{<=$-yT4GdMXtAkB%O;(KDJ3f?56TSE+I@-LhSHek{2th6x} zNi>`KHBl;t=get?1k5PE#;u(U(Qfa><&1^d<#2VX`4o8lt@B*(O=lpx&~3fBvGK&< z@gKoCYw#mD6kOa$ZXh{P1R*b~MUBMBaz28+he3sqnbvT~DN0y-Y^-Zi}_$|#~;ami3M1&zQQ^l!iY zmSVg}=~8`}giM=`#3q>tI*&;t5J^SM@w`1kbs^Z5yDmITPesI|861V#t!XbnDw%DW z!7UntH8v8T*w5e)zq|&l^DT3b&4!l^fVR285Y|N8_70Brd%L}X=^yqfz7+$B{R^-3 z^Tkq;^mmP+Hz3+;w3-vVmjXXn5BYc{+|SLSIy#rnBo%UhpJ4m7VfHC2baVOCR>$4H zcf|es#M<9K%Kq;0^>>S`H+OhYg6ioUOi^4LPOl5L4o-F9iwZ$kqQznA`#Sf1I};D* zeT$1lZ(pLV_x<51R2Xy#kJt!G!#r=87X}{#-AFVw3>9ATJfm_7FLVRFl6Ar8;laTX zz=!|B7YGqs0bK5Et3I?GOvk($Oa6$EGC zXp^0-4H)H@ML~Yk!`kQ{n{`kkSgS@WB6;c~`a0_USnD98Ju2Q#=Ng6^K6Kjcb|}&c z9^0K>-|Fn}a~pGE4$&CSX3ldtKwtGn;%xlT>Avk;`l@bDk+`%RX zC0;*#?k4ZiYIJ0or6o`6p#8EYO8{Gc3F|<%u=6pw%Gi*REn&>B+}P!GywLFRc;lGN zyUPL$*dv3qCm|+GfKJ**BRg>ldxy36_YZg5gZ2)bbWKFkMI@nvNO}3%RUrIi-)_9$ z`EML ztej}t8cs_v*T^>UnATWVOyGj?6+S%R6A5_N*=&x9N_PT?!o$ll_XAtu%*t4(uT95q z^Y|n!g~*{7Kz!G@DwnB~T=L13gV0K_^`sw$9SW?ft-WI{8o&i zoXRrJQ6VbfE4WUb0ohc4K(}Pwxh|x;YfW)1Gt$w@f?x_ZZy=}GGqnzd#GAphZeN&G z6m?O;=9TBSrenT08=QM7ssY@4t&OLknhjo_^q*1!VsDS3YJ9%JJwQmL&}Va*9j1PG zK_?Z+tu*9=0N(^$w9TbuxDftk8vbeTKf35KYrr7Qez$2lcCbzy+RvAdm^CQ^p)$(j zHKT0GD1AFhKbe-ca*(f94060~BFC#?f4vg6qJNM;KWWBZIo3BT#^PL4I~R|(`Z=5! zm+%*4N?oJ%+D6NUqkX$}w0L%WKxWR{Z6lFwNJM3nCo4wL#M#uW!hvv78aJ?NPJg|_ zXw^MCoM_Mw?%N&4*<5n$X&ij4GK3BP#l)K<<*78vav3YE&=n(K2 zcEnZ^pb|VIfhOV;(MtkWf=3t=n{eR4jpoMdlP4q>6(|Idj?M=Nu3gL~!<|zQXwZO{ zPLEFp7%t!2KkU~SLcLBx4@Xl;xK0$(qY`;U2^eEWCy|5u}j<)RE_I6C{ zQ-Z&C_fNa=@Z^8SYa)mq!jooAH>o+Xy~m%D7^84ayz&>c=<>~XX2Y&JA82yAR70(; zLl6B!7%JOL%rC*w?fe`r8_gC|q0VnvxDn2n<8}&6?B^S-zGU`fA&F^=juMwSXjNDu z%39-maxu4=rz}snc*fKm6ZZ)`pcc$~A2NRmWX$lVz&1jF$z~2fc`=(9@}pBA|Ae9r zCpp}ECE$L`_>vigQ3GoTg$r-mK><{@(%$3C(NC61rAmEI!h2jJ|2HVPX^=C>N# z02|hn*Knq}x=6chB_#H=ADt9(w@XscP!e5K$^vN!<4dC3>~Z4S#t9uS^4YDbgnFZ1 zNmQmvxwwNh($VnU`r}Jl*TI9fewZX3+E|8Qc?r4ghdM;j&5TR=r_=kG{H!B)0 zL9s$;Puh8=(aR?oIDDLF^7-Nt@kcTCCllclW!7 z2K1`+*!e~_V0NsQazT3*VR(;>aWrxCeZd%xf9+fDRh>o1qhUt*1RVn&&hAQaXT|YP z@kJoP@&!Mc&KpKi%o7d@KN%4@g0hAXTuZ3#MxwMba(JT->a7R6W;IK{8Au1ZnCF~T zKumFp_GO$Nx|K(0ZG{!EY!}54j_LqGhoigUx}X@~Nq!^nLcx8nW@^p;Ay%Cs_6i$& zc+zA}-EzC^FBu)`gZ7K=Uhm{|fcj9)RiWDRC`67^Kp}*}Ax`L~DDwtRMnIi5UPT z%uvF;ki76jG$b8AI@5BdWZV0Fj>|#0{*%31-MFXeB z+etZoN?7jp_x8yj&tpuLJ$9i^21cjrY{wQc!3Z=Pw(4|0kDsMk%m;Is4`4JQuZh_W zA4^XF;}fp6Cq`4c&oEfqZG^oZ5ZV3iEB|s>eGVf+#58gyJd{UB4w3brYw@>a{%gP) z0!ojrGj9!Oz=|Y6bx@>GPEFGQU?E}N98XU*&YB(^o}$PA-^Dkle;W0c0+G>0-N;9X z&wpSA9hCG$L$mUs4~mtUxh=UtCN%O#y(z9Mf`!9UHvzQ9r|BJ7x+c+je2?of6#YDR zW&lTBK>p#fq+|*mv8}0mo{WSUu@vl=&4EW;Q)WK}@S_Axv8>sQ!rwzs?DcF=*8DYv za7v^+v11f`-%iJGDFX*M5XM_ePIwH+CAAT&N~Oj$gM~BpwxAdjP3oF@X^nb>B-((3 z>!@fFMI?uyD3DcUPJtKgsFIM!md+oCK$aFuK~-b#vc2JT_9;cQx#l6*YLquBw^{OMT_h%|kiEAB4} znwx8h1kCd&ri;=^E0mL-lK<>aILu!W+$sW)(tf{(yYEIu;)J^uv#;T39&Pz*Bdolt;kv!V(^V1Ot-j z)Y6*VziD9TS}rDRft@Br%PQ{l;t_KoJBmx`yTj{gkf#M&4+DQ>#OGA&CVq#>1dTML zFnCQOqJx)hEJzZ+O56+xH)%@4t@I-+=-F=`bj(BZ&Dw`I>58F;HzE&!xI!^YQ1eb9d$SMCY_dEEUNX= z=iJAd-xR#X*s+@Q?nQEJYvZAG%m%s#iK}$n1CuDwvL)!UZQHha%C>FWwr$(CZQHhO zoI;;_yQk+xOw51Su_Gh%Tg&-)Ek?BcZ7M1qTrnaU)piA2)!iIKYi4C74cJMJ>`a@L zmecPHZw=@{s)z)=A0%+5t)>ihO6d70g6wBJYj%scg`Gne=&3Mt3Qn2Doko=u%#G~x zJgk@i7QAT?exgr~)NbsJ7F2+`^RDv&$Vj?^DavyK+1e*1*TQd=G8>g7RZ^N0d*f$YE#Y-OiuLm5ZL#b|u2_95 zuQ?P~W*=DD=I;|AS6h~FzBf2Nxm*?1(MB*SaaEKNEIqZ1UO#T;`f;V@&oi9l2bc3s z1c8a5R7*-@2WA#j4uo0DMu`DW%whg}itQ{UUaT+EBFSKhxxAOe zMh-?n4f6~?MQ=3JTLGvxcK0cKVwcFOu(uzxR3T!0_>GCfa|2H?zt&;ex7oB*siI}@ zs9*WJ(Fb+p)j6xa<+RW*4;n=povV39GRF#PT#mtKVqj@+!fSGqs`+7CQptAcmUm|R zwDR2aIj(GU_;s=2=Pz+?1DXf1hS^sJ@tNbG$H0&x@YnS2@Z$4k9v_2;(UZ77r z43Z#zTfEosn>|02$UvwrnIJldMJT_f%TZ;A;ot<>{t_a>+CAQ96-&@pFulFmvK8kQ zXwse2<;er6rFfQKqcq}1#ROtB76ToI>ykwluMHrNR{8x!Ygw>M)@%=L=nxTBRUxX; z-ntc*x0oZKo4|J}lkH(96r#%dVR9f{a!m{4pkN>f9Bs6rNTltcb_FL6M677K2KLxO z?!ih)aW=ep%y3fei8wNoBM(XK>S$Oe%v!RfOk7rkIc%^kOZ%SApM(@bTc^MKj*s{4 zxp6OQI(mOsfPZGbbflth=C}4*^nR;WzFG!;y?;rqVSSq?@NFi=Kw$a(2J-sy=VtbP z1xaU0vWJX$NyP)Hs^d-jZL|8m(Wh_ieod?-)q`5D3;MFf7@mh#>+V(Ay8J=CzUzv> z`>1F%@Y1OQGfk49r9nkpaaGA$QaIP$#=sV&!=l)}n#wU{g6^#Aj6qwR0}0pT)g{## zGvHP9Qtsbz)!2(L;-&=p>j(2+-3z8AYyTa@Jd&m6GT%PNB}Zs)RS=g`2z^ZWUIvMX z7EYV^CCc|(JzgKfYQZFdt3WRz>tcKfbU{@dfyVFSw=^fksvM$;po&Ri8dZ=>B&k`> zvG*hlnf3hSVn!tK+%0)1(e5hB1hZLo33nUIv+Qp=l|heBc~y^5Ksz*ibIdG{9uzq_ z%n@Wl`P@@4k*F^f>qRPuXn6E{6!_jRMSPWW=D=%SPaju)$`wj^B&nv8L(WH9#BR*L z6HOw&or~L=4X(0#(dHA?M_M`DM+QC(-@4>)fmkA&Rvux7c-%3- zT)8KNW9J@MVO@2ZYZeFld^Xk2Q*9Jq3WkVJ11<-u(1beq@d5 zy|!{Cz-lHb#qm1X`|`b&32Ia`!4LNewg3Gq$2})Bzt{b@65uO!_}(3pF+AENq$X@i z8p|BdTRAvkgeb1PxZysV#^4FhthDXD7JzWl_1&oCvcnG@7bI z$EBG3*{}9vjadh8E{I#G#Zfop?4>@KdaWVJ1Cj9DHkN_=BTWSGz2JoqV|ABEHXrqT z_@h@1_yyR@LioMi*)+a;7vQg!yhter9=pZ|Al&{&4KQogY)5n%J)5#C&dGogV*UK_ zXbQ*oe)`-(tT3s=_)tKq61Ul5TyE6shozLp%QMX3k`ZS$w9eqg_1NuvpaH+gF<6t&1Q^1yJ z#~R#At@(*(kz_o+WpzuQDDrnj^Lb){18@PJeD`}3fIfBB;Xp&PRwn&ypznYsc}4&U zvi<2#EZP`ZF1DQB!#au8eGy=YZgW`f%1LaX;Y0(Hmlv#Pf%-#h>d9d+UQu+CU5+J4 zS$wBfi^YWw6jIjc$=3mu% z$zxXH#Znd%UAI3T;q~~o?<@$S$QMJCJ`<;2v}qC+w(>7D70kq~rq=l@0XKW)R{b-C z(7EAM#23|Abd9S!?MDiUk~O??mNzQdQL46XO4|^NJL5dC>Ar-_AAcUfih(%8&{%RD zs4lT_)iaS)Dd>0KoSuL!UUcDsp-@@8@<)vli0MTJsy>k2P>Nt!Uu13Pfs=Ym6C za@u{_7qE3A7mI>(L0YE1^k{HjKm&t_8^dOWRV-z?Nb-tqmLyq_l`B=1LY8(UtSY#+ zfw?f4$&&w*!%&lGf$mZlqz;yvzgg)n5=A_EFMjT?{lzn(V6#N@rIw$vbN6Z z7fgZJ<&Yn2YueeHUi}z1ZH4pOmB`wt=J|pWF~Eo(T;9ytol?3ZVm7C}%5Rar5&*G6 z-jqtJPC-Wl+>_u6Nwzhd7UhsaMaQ+BW9;HJ_bj*b+qx-UrzMYuO2C`8G(=rNffC%>shxG5vtgMav)3 zvQ4cJu{3~y$u1^(&93sMe#y3O&Ud0|d~?*6uMp(zZ1}DvY8>9(AU+K%gJGGmQ|eib;r;hTc~tpF}KS4 zAp3K)!UH!`3?b8zVFmdINqb&0t2nqHy|>4piLd+?GEX-ew)VMr(BND0OVZ2>)+xmd zd8=p$v;wpNRFYIw*J`Tp?j!M*|x~8{TjC;wsL^T`=eAR@&G}dYU?S- zU2Kv+uUDsi$p#Q!AtP`Bz_E&56Sif$Rh*>3XCq5iUR;Xy%LH?M$B9VK|)$nBq@CxV;Cahb;rvdNf@=vF#7ff=xQs8##&R> zQnn{5Xm4OvuFeg(v5%8u6cq&7=#dWwE@>E z6Vb!#uxS!KvLmBRxdtQwWL&q&W2MNlH;r=0J&J8St|+mku>mja6smt}lX{yX+Lfy0 zm)VN)p6`ACWl6y7#nk0&W^R3rDoj;QO6Ur=x=Kn3Eqk7;YNp(s>t?D~1r2RbzO5G; zBxaJ@CRH${TFMEJArQ3r7Cnf5jK!VH;EOxCN3Fh+N#|~d6>mA-dokuhXKpINuYWp&OTB?d5x1sBd`elaMnJzc2#7dD`qoBUdghv{*c+1t^^Y)Z8$L#AA5O z3WRN@3SRWACj6*xd(v-`SGZbWBtI2gh+(|ngGj1})y2~Z(c53eJ#kWZ=L**I*|n3M zTS+g4QOwm&MYnG9qx)5WbH}k;-XX1j{BYPkg~3Y00=L8twsaE61|#-@TY0wW;l%_k zZBKv9e#|3U0_u=1e$!ujgg(&n>cxY zpT{N-!xrrwrveQGBr2=I$)z{l&|Gr#1MWSe)C1+BQ(Q^qJag4W&bm;lf)2Z})jLs5>-bCKtzH7haC(k;oBmrg6ykEi& zGj?ovPF^)6n{ui%sKD2>g97};B!tSKcM2Y+CO7A?f_49jH}4O@oyY z;%}Kdf}F+3st|(xfeo*Xy^&M8(G=>zKtK97@RkAHoS2BgM@A92kK4siKat|rs)vMa z>gm3a9W`5!hNW3YFJu6T(KUIH;a!nqGfHU5J{&_JZjEDPR*aIcB8DOI zBiJXq!Ga;!rqtF;9$x~PwYZhT+s?t$JBHo9Ww7liiHE5{s}zNcA=r2OCrby8)K3PW zr!569o#YV^?-1)9RzA^aMx~t09<~*#i1x@CkB+mUud8#HJ2myBo7KAC{Fk-A`E7=I z6*2U0IOMi-ZmtaCCT(eURV{^uzcWR}Ro1VeYDt$%abNN}6NTxK5~+M?FaVxwSoS_< z%1hAYBKiiVGWH85XU?b>Z1TwJmJ$0JbQXCNlGJkKY@Dya#S@uN7VZP7*WEOUZUP(B znphRD84RA1l5A%83N{InO(b<)ivU`LFs4yoQ$5zz7dZD2-nS}jF*ZFZv5-s-X2y2v zb5wfkiw*P~;o%Xx1)c$LvajbrF|~4cY!Hg-t2>}6@pI&~ZlKD@w|#H@IqwbxLt7Mk zyK*^?f?Qqb8&&e-T?5|#0NJQ&-FI8oHp}tcfG51?}b4XIlVmPD!Vn@tn!tQC9CvYe`K z)3 zeVO*`RZ3XH>W7ldMZ;0o$ci!OEoSSWu~ZiiUxze>0}pX2D4Uueh;z?E?!f8?GqAd?9n}CtgEaTqT*z+gU(9U< zui~rrU-z$mWv^8WPY+hkk%vC-2Cr7Ax~<>p_AK#<7Z$1vWG}(o3g~ov?;^2uRwA|A zC-nHw#q?}0)$T*oc&DsAzSe*0uj1n<8$&ahB0Sa8sj19YHZQrmZd7+1&gw&yo>lYi z_)==NwJrj46^?~aK3(vA$#A6YEc52tkqlb#ek(mSzm-{Q)Lz+T!_}y#8Y?wco{zlJ z1|lPMY0+En6n3a8O;l1^ZA?Ji)+7&0tQ=wkB8*v2EALtj!0re~h<~4}y%t$tuQv!B z{{}P#eC&L*2I>0fB?=#$sEI8e+sA5lwJq62(d;13?VwRP<9?Z&)b=_VE3p`l?b*=O zl@T!4Le?d9u`iA zF^i!3X{(4uuzkRs}Y#%c!Vr_`~MLQkB*+bSIeNtU>PeG*S2%-ZQ( z*SABw)I+kB**Y>b!M~D3el%I`tJZUATyrS-wm}%i8FqqCgf&JCarJAfx{Kmel_;=e zP~3{&evq_Ikv1lU9Q$=A|K`Jpoe7DGw&v{i?&)v@^xaSMG;ms3oB2#*;na8J;>YT5 zX=v!TCP55A960eiPA+D!9E#EC7>MA6L{#J^y%Sy=s>e@;u?;)oL8TNcv zmGRw20LCsbU84NPk$H5W?7s`C({xKS-49M+9;B`Dr2Jc=pNLi13iG&*F7UD%$R4ML zM$bj|FgMY0ma}POgbYB%?JUpEhF|NNy`9?$zo|!hVl&QJ*XRbAr!*76O$2I?tjvM4 zMcH6Nc-eZ~LYWah;Bp>Q(M(@&Z_Z2Rdz00Il8D;0IC8n^lQ2A+>wz(BS6h(JVa6mQ zEd#G9{D-T`MY*_o2VA6GBNPDvlVe?|C{q~a+*AeQm=PbC>uD-HMSy!d^7UaYstWlAJ+Dcv~y}v(2(rfGAGO*EIR!pQ<_g8P2fo% zcNHxq*-!}|bONwx`Z^A4@s)}OyXuAy%-X8{;q0#>Aw|v{zZvHGnj{IbGjCXK0DYkm zjd4$qEmaa3HMC(C6>8N(>J7i)@k4WE&9iO?%#IEyu13`*BH3(?F8ex zHCd#)EMzlH%^1NIUO~GDJt^W3VfKa#e8KvcCP2+quxrRM_<@}|bENC$M|kLKAI$~D zrw9s+bIJd`*c{aUWwSQjsuP!~#jNlV1TTenP{HA}*IPhy|8Pt&x}2bU=^p5hBYI6a zhJ7=1^ZdNM^t`er_WP~5<9aU-C}z7NAw+dctAB{Jzf})m@0&+bb0NC`E@wxoPo&v2 zaO1U06JeLd|Xn5ITkUc|LxNp+7CEgF7R-}{~rqYUR9@G?NL^(6I)SGmdF3WV|XcU!q< znPgNxdmD3YS*SR*((1lR(da2LSk>H)tuTg02|S?>GmG@dQ)gf2u(3Q*BuT33+x}0A zXF(v{;-BM{Ws0_-_M$1&3V+?fSQv|cn*Q-y3JD!C=6qD$D42ZxK=R!ps~fJloy{?z zlMRgHauLdtZm@aSd+nk=Umvh0)Z}85ZBtmg9Teiox&APG!9{>ror5^mPabJ+ok8m~ zc~JA96haV@de0mbJ~(x3^H6hy*v2F27HkSK1Un1BYTq(Yf3xeZMFaMzq79F16Re%z zOi`x-E4aYI3n#l`k+ICd7D1Fx>UP~)I_7|ITdN%|=wdm0NM;}3iH&tLer^Adk(I7< z1^fZY#}Ecmt$<&~4m+%G!U}vjHeJt?Cfsq^z&?l|t5M@%nPm%A>FIRDz88r@5&L@9 zA4d#b`Y+7g)rmXq9&VMLs(uSj^vHywh@%X=d$e7ekz^|`Yi)j0K*V_Ll_%0eyem)N zA7b{S6i2`uvDWkUt#@*2Qx7wg>vgMJ^^6z2J4P#B1~)7girW<0jK|YapHlC-2Q_KW zrjjDXw^JwjNFZ~|UJL~A4VTk(I7OX!Do*(Qzn;9_*Wd@W_(GlaT`{kP9sr9;APXO)g(0te|AW6PzfSIas6wD3w;4c> zCOc^yu&Z-eNBB2ehz&(0Q@uZ^#LB8sxp7a0f!-LwE+2Xdb*Ame-$SRFCQGv1+B+Wf zKGe{9a==qXWRAJBq)AO_?v!Tho=8b;tv_f-V3UU_$ERr$B~>gV!P1#SQ~7~&&t4q; z2e-EjT`&+o`5D{fFEmF0#}9I%<5M^1T_CKD1HBnCW!gW@{r{nM`m0ge1xX5hU9_WZ zU;0)2GuyTzi6^_j{{z{FW&@n>Hbm}GJzWN4IiQ;wo136LBWDV7e1DXz{S;oIMBA~y z^MrI&BSU6rV$1>GU9x)oH+|)ER>F}w*JL=|OTQz|tjVEO;DYw|QNDBUywR4>f8>;l zWGFLP7!$73DhF?8BpbxV-Q=i{? ze!;(T(7UwP3H{l`CN|GIwC?B`PJBAz?%$;gJb}BgFp;UOQ{tYLOt=(O&P5hLIB!8@vN<0ZuQ9 z{I2WlT6}8LwiLIrYWnMnT2e_1;5ILm?Nq)cKd-YlzfM<$*^dpTHwatK0C4(s|X zV-apjm*|HF*dgmj(KwB+AtAB)YhOy=^y%;C*2rHf$A(tZho5Ik)J@2WJ|wy@rl|h+DnNBqisHl;sOxx@7v+zs%05rXaY{ zGV2kTFAfSn{op-SVBw*HQb4h2^UHS8H1!O8v<5_Wd1nD6QQl zmo}+_59b_nzb9kf;DE7CnFS4Kc&Iud5G=HMp~>pH{I6=xj3lTo2=W?rQ}QA-oJ=bf zlHA0MsY+^K3 zhB%;yITY!iTP#ej#TUvjx~YHOytokO5)>sOAwEMYmE}3MGhLds8NNo6WS)zK$uA-x z!JS4})Veh}qN^bsMBT&I=F1Ly33VZd*xuGu#ibJ=VXM}4*KwH*pD zIpxBUwjRK6f~(aQUrmSn4AUI>pEu_M;kefv4Yv@4RDH)R=Wd`7n2gg%bWb^S0w=)BoYjW!8?AuS$>AKGf^@mVfX+{#`Rd z?vAfu%KdnH@?Q~}X}A9{8*ftao1`~~N^hxFT3d<{MxN-$IRVU85<6mB%Cg^*Wz8~G zE+1y;{S)SEJX1Mh<}uc_!2vt`KFj~bpsUmnS*CpSe0q#emwerWbT zi{SCJ=!tTaE%C4EB>{|Rj0(l|OFRF8<)9`1h2_1No?Z3n9oohK5!O_ba%QjdB+M^+ z(xvRkD%JAg{k7Ug2*(VW8mQ8dT^@C`Mq1)**<g6E!0sk+;Rum9 zW6ZN0gdv~=NOt}*(v;dm+_utV%cI!C!18KioM1k|=_Z|`B`Gwjgr}qpo{BeG`Cyi`_f~h!M z#$Zb}W`ixJo}@N_BT$Gb8_}+{5VFJ-DyC3Nl=^OqTvt)awp1~aQraq8 z)8u>i1d5t@8!3EVxVKSd$N8dWhoV_bYwc}RQU~pkF_ErH@b(5Lk^(8Mqo~O0w;8`iz?~J!ESd z76RQAFi%movaL8%4q2t5hNw@JQS+Q&mdK^MBBzY$xJZ_a&QD(2+_3vANxKGXYp@K!i}vwy#jqMqWJ-TQyF`(?`i z)$XlSfGN@cCIo%5v8$q_TiZJn=2;81TtLLZ)-RVJA^}JiAgB4h?^i7-B@!cl>W+8` zx{0q>E;A_ukeo3Rr0`;w-iRJvs&ak*HflE=_w?LKIx%Mbg(j^fUH@jDEv6u?XESqm zdcKA@jXdoHhbbK6rUMh;d>dPa;Iy(Gb1+z^^}XK>Ys|@NUXIPXn^&+>zx6xISJ~{0 zV6YB+h9hyu#ChrP34vtUcv-E>7gmP}vdK-7o`f<4I#AzwyvGO0_6eLScLvas6NJ{w ztH*ln6cBG$Odcq-W0w3%Cu56RHF%{4__%uOKVE)T)aO#&Sj=yk4tEYyMaQw?EM+Wxu~KjrGC;j;gQ^_l}a zuL01Zk9ljQulb&!ugF{TeD3eZAnPJ`VnWwvv{aJIck~c_iMv-nUO~Y70dwF?MO9an zA+K7=;Zv#Xm=oNvNXh4E-h42C3L$*cb8pK^XAf|Byypto7l>|ME7Q5j#6<2lW49Ce ze=Rp?zEgY5oiJk*mkVi2>XVc9$k*8fVX$*lchf4{^Rj>^grGj5tnLn&<*|29B|tFx z8zt`BrW6Gi?k!1h?NH8Zu$-E&Wn`a&w&HS=o{3lC73;(mIS_XLQTrGWVJ=I&n?S~8 zQwS_sMosyKX($vb*xmTYLvc)Wg2@#;-v}4t39~_>XK`HBO~+x}Ke4I(w?%z4P*C0+ z)iDeu*w|E%QTy^);gt>2JSNk4sCE^8^WvU|p71%YUAVQ26ehUFuJ0XJZ9d_2RIYs4 z&~{ED1yoA5@a^HOQ<2Gk-D3ju)H9P^IJH3MP4Of$MWD80rT&g6el$xOXdI?rAjgbh z4ktb~(C0s7{)uu8Hb!nyF&xLW)TN5qmUD#p->h2~RT}iIzVb8ufqsNd$_IJ(aM239E4t;_WRE(c9`J-)-T{P@C2inz7tM#`e+ z8;WmZ$;(N>UQNdFht3F`y3p?z$@Rz|L7?yA0k;$Ny=si8r`a2Ap3O_6IPSD-Y-0)C zBHZmezk`_9o6Uv8jR(Mtj(gOs5Pg}^6ouSs43VUBr6wrwK?w_j`AW|37q}vow`==C zLGN}uHw-hUiH0(V`-Vvbw&%P^!`jDP)lo@?!1x6jC0AVGv-4uFNl_?lC2(`x-*uJ+ zc5|tR$#C}|`U51Dao5svDk(LC$!aT4nG|~$>-@so&R@pR*w(_tB0RP@nMMbOmp_pD zV%DU9R0GUN=0tpmJtX?1?!k-=H&bW`OoAFjoC5YYhGdkt*)_^RI%Tah7Y`EvN+zCv z!+dC!l;60%#lLhgip)qK!;u(HM)%HnCkHpqF70ahaIZjdiVm_fvv>RH-a~`o0v6|+ zOT;h?BCnXqG|(3pVX+&4w1;a$Pz_1MM`I=w#z{LT3Qsk z4=D3N>LLh?;pH-06iQBqLuvga4SR?FwHBAsb$TDE<-SIesx8q}hvDJ&Vvz0qe+2v& z!R&e}9FE09J!up9k)*Vib8`E>MAaY?_;Fpfc6(_1Km87H@_+Pu>E8d=@8Az*{i-U~ zAR=f;0+>@XO8PLQ57HFT>VMY~JHU2{pr=z?eIDxxkfj+9&@ezbFFAYKE^d-=msE@8 zmNdQG5E8Mld?OYaa!2g=Y@@#NQE*0t-v=CK{53(cH-js6;3gd5_Tnox#?qo^f57<; zpH+DaJzV>VIy^85O1QVbd`c|J8Asvh%!w{FeU`kenm$)gKilx?u&yqcC{!}PtvXd= zSVS@19Za!Y1Vyx#sd;NdAqX~b^@$1EM8Rw6=QBq%TA(5ZJIY!!Pv%pKpG2H&Ta#&^ zB^UX_5*N#vSjT%Y@GvIm;*kGf$)39> z%-OC02A#EtqG1}lUxTf)#c9^^QNHnCviwKaD?{UHeP6S*SHQ2G_XCZ7 z(uD)FUejW!F=#PyMPn@|qZu~~G};L_irfP;Bke>A_8jZerX4$~g1r9+(~qqIJr$eS zt1Armsb^AOQHc>yx^IliC8-?F1?9}<;ab^a`2NH7cgO0YtbDYlVE9JU_m=`VFu^71 zslP7n_QtWB>Z5gCaVPD~g54WeIoWXY{xDjG`zW)dgW(Yh3izD#N>C5%U%1G;;SYAJ>b z6^#oqBn(=x8+0Q%e$H82$a`uL3YQo{DlpJ6xdT39>Xpm{=FxXk&=(KhpVdBre0b}U zk-wZy2Vp3sz=NM!2*-2rS@42TR3(haBFY^-cg}B{>ljf3oQFqtf-8kqCADHDPUf<1 zc`n@a0Yh%Sw{7sAUH7;YyyvllcJRfj#m^uGX|8gfz|Xuv<10Hp51A~dmUU5u(xcUT z?mI$?F+$b@H+5`Cnf^BZw|quzB{rmpI|rXPMXDu9STmsf>RkAgI&%yVl+MVG^az^7 z#yX?vl2*ihVZbBo7EkhXtdz-9+V|^L1qM}mU6CyZo1sYjqvta5tKBKiP?23xJC)(k z_~;{d9@%9q=n9+Njc6$%t^1meRXgGcexeR$<_piO{|40NT_uY4cBV8oUppodF>+b> zqAt;8=ksmIhlV1PMRWs0{Jr*jqy!`Ck3m`KT@P^0 zI7b1*4el|3_AD5a$D#4MMP!ssP#a>p1@dE!A04)Fl%N+9*Jy8F0lL}pJZ2n(+LCm2 zS(am+Jy+oG7E@kBz9qBZe{`CF-Og|BHtT*@EPpol{d#|qUcvY`kK@=*hyz3O`u6Aa z=Fd*=w$)XK%O^Y) z?<*71ix6qC#4dHToZ{Tol=?xJ6^a?#o*8iHHt%LBd;m}7egLSpA%wLRzh;zR!Z*fZ zN=QQQvCy=13`Em+o_0l|Es4Y-diJE*9Q<7x2{$j@jx|%(r%_e+&HM;E6Ta38+BG|^ zPjLLEE&z9klGh0ouaU9>S37ZP+oY8Q7^jTe7QG-?J!?c8I@b zFOX8dxy^S5&wtT<*eO$8<(x9o`A9yJsA<3`WjDRP*TLjePfV3BB&=Vls>E=gyK!j2 zqhUi+IZ36;n*7bTwu-FF?7YvYH44Jfb2&W@ED);NZ9L_cQeJA*uYVeWn5wU)cGhb8 z_lNFLu;CHCI(yD?!Om>A#4ak#N~3gqeEf>m!LI)Ry*& zgr&~+f)V!8;Mn=I;n=I3-NBi*VO+KBAWbKSD>4XdQki-=tFSgwRR3%H$c9)m=#dgcgEKm#ozUap^spgt}2!LGg@u4<3V z?r2##B72Nx_#P1>Wx&naEo#pwHw%399C~Uf-$cIM!1ax}AT16c$3C#4uEF78)w771 zCRsHJUg#Z{G7xmbpxvSe6?$nffvVZ2{={BbuTYq0{;ohHg2UqmBpAE*BVh#^@6mlg zrj!a%P&ihav{r)O1%T13@@e=L8S;KW`ep9_)vsdQj8C;}QM4wpR}OyDW$9455W%34Wudb(=r>?h8{A0kETH=U85uLq9HFS}!_f%oNw>&8y2tm>X6j#+%6yP92l0bP_!L{2>l&p=5$ef_|+& z_mbFM;V#DLEiPwxd?6uyUxH8|7T{O`{PA_uCoCPTSN**jn7H~#lzD)14xb%ri6PDs zFkM==uy|hF_l%u7Fh~89xs0L9;@=;&T3=L2MJzx=D2m0}{X5Bb+dynX8rDcC`cp*1 zm9ziMSe-+bW6O+gAIeQ}a2o6R{xl5d@qPX$WZM^^Vl*ztM?Xf>R@LgXCkzsM0oS`7 z5Q~yDN40ON^Fy(x+fd1XPo?89@hyp8MBe>W6L=@&U)k}rjo4@SWR4rPX>M39@6#%~ zwC{?vf2uISl#mV;?p!;&-}IF zmuMx{)_X@pCoR~Iw$*m$q^TX%EA16lY|dEj6BIK~R$l=3Hr}cb?cP#2m2xnC zBSFQ=r@*wS(E+`)g@ku~kV|47ZRCUbMk*GXb(>a9>{$H2?aUbVxA%?c)12&$he=nS z*VcD;<4$aY*N(_{JhbFXF;~1vY>6IAEUOf1akF;+Q`A1<)f=nzIVkjF?WPC;{@(*^ zj8K_TJjFfw(xn6^##GsL2kr{=JP^BfcN@Dr^KO3K^N`SynwZXYuMM-CRj;FBuSlwG z{WxzD+?OY#b{N$SO-(Ze<=pVkg&|(r30$+7x)w?Kkv@USuNFFe(GTug>2oz~K^q<* zBO!!tQ66!f#StmbVSTo%xVnXM=%MF%mT(YByCRJ zi|?|OIrOB%v=BAe0!0Aa`-92@N7U4gHQ&)X;M(B51X}nBXC*Tw-i4NO?B5`A17bhvn|LO$-A5JiYs@n796Zbzd`tZ+K-mz(UzJd4#p0ePum!PHtObI8+Sp9Z2aauDX=z*LmFTfWf%Xv z*E%t%l>6snzN$yt?PCCRg+j`DS$IeI9Y$&&+T-vke10$=5w`5kd-tFjSLH|Rp=F+S zMpATwvaU|wcUd!&5Tt_BAVvH(rN!Y`O9a+zP*?iBO+Wk6GuJfpAkBi}$@RxNzrZ{ipngk@K#q>5GnjSY0N!2YY2qE03K~=5fND z?4vPuruk{jOxhgPWSpT|pK z>GF#0k9G{E31XbFK=mhQ>G8_vyt?PX-4JxhbP_Sir^4|V=<18Nee9bJWlFAAKY2N$ zYusjd6`X`qBRwcK*b24Z;f`PX?7zefTio}XU5uL`X*y?G4;+#7yLC@$!=~Gj0q3!= zT5=lScg#Dg7F0~4oFe@7>`*Zjvo1?ME7`0|A49@QZ?P5?Rl?s3Gpr~aC7Y_8pR;ZtZ$TUkkn=+ES`)@r0hsIju$ipBZIuGCh( zDcDCDoLw%6Yj!56WX%>h*OZVqRc(LiRcn3y3mLF(4sFS7lvt#l0OcZZZC@(Slw|^) zIS!s5Ldvn-hU@VZA0nKG?&k#t@0%-61CoAz4C#Aykv0FT*NYuN&1@jetYB8+5MCopK=&pFJjP;novR}ttJ{`WdIqw@7_J&(*MkZv{@ITy#7Dp1*TV-B;#DT zZ>-0bYHf$9jW4}6WqhmZ*6f6woesL@Lau?T-f>+p(T zI22?^AU?7hxkCP~+}tv4fd+b91Ug^`oaK61sfHf7;M82oM^6|t^Fz+N+td#}Yq{nz zvODP*t~9WM=tgRz>}d8p$)|7a*7LD8hTmU^th6kaWG744aTYCZ=niS0Yz(*Byl4v4 z&rvTtBxW2nmd*{#w+h$E9L@y}0a4$>&DpZ`_D&y~1ER5V&$dzcvO2hq;u#GwK+kDN z({UuvmUL9pJjFv~fRkp*k^Q%Fu3FN9BZs zVoASz?)FR6=d`OgD;fH?_-L6wB+K{51f`M^os_>Fv0d%1CRtErXy^Q%O4r6=Oui~0 z_uTKxpdB%)5yz4yxIbYUSbgZLOiu;;EAsZuU})m{s6Zy?kDz6q_4&-Pn;4sl211$} z6{312FiV;mq)H-9%7PsqR64YaOh*@KX~tHuYsQM0-c{vwsH}G>Q9~F>GV=z*$1o}9 z!+^=cQ+wRdD#p^H2|}0i;(xYE91_dx2u|`cCUWKbLw1LY#|wN-9hG+!7pOWV_IK-Um0L4p{3}HPVx_8lFNjsnU~!L`f~Fx-Y{ZF}WX-LaEc2G}p}B-_10`p_1zNV{WM= zAeoVtUOEwZH3yZ*eGVN@I$4C`OXSzyHrA{kT1DWFaUJMzIODp5bflX<|cYtVvA@Khwrp7_ZPH? z=H|)#l^~71k^UOg2G!*+Z&~4RZ#|ss{F^-+jxV2@6`np3T@ki2s@^F5LEx%a5_`#P zbPgtu?ZK1o4^eFWV5GR3`2@wMZLy5Sj$oI1ttN2QM=I1_B{(Gu4Y0>K!W}@kwThK_ zQLqL%!3n7sd%NXb!C4#5=Vn~kuo9_6fA>him>eQMN0%t%ki0Yi`F;atrKnWq7F(!!MCF-8yhl}AP#`h+%$3?HrtCw~Es&wm995d1U#gJBl+$gv8hzxy

}0zC%v5E*Z!Bpt^ZJ zgm+|4q32dprXBtk3pxf%%|CJ-<_Lz)Lg1Mf6CyS>W@wZ=FTU!f!dV=oSo*0pvsCe2 zza<}<^?A%Q!q2c<;gc=(lks+U7)#Xe8I`1Y2D%=ckw*b<{`-k)N3mSxKSk2Nl>lW&1A1|ZswP70Q zhO1r&-02}Ic6sxdd#^%uMrNG!ZwF6wj2XD@PDvlTXfWtXJI+!9Ontv1=)v3C*uJ-M z2Ij24+FX&ybM0ifmbKE4@Yw%P*mUDxu2MMet$XLI)2duZzMAdmDuzOkB%YO<=sNuNfg@-MmeHGWIRFqWw&i z0gfcO1ANzeIR!=-+#(8quHQQ(qMe)LrM9s_964#!EG^XXGdd`aUe8s2H)P)JdnWh3 zQv6seeX5r|H_TlaTYo$x|vgL-k3jZegpN^?UC$E2lSQlP@@GiD{qYIwMovCmh{(E?@`$gL31zXmH z@U?sd1Uu&bUh)QGDyK$ApZBU3YlvflW!<00xd4NIkf?i1Xl4CUgC~SZJ^MaWEyyh) z{Tu|#*#X0W(#wHr?FqTRH^LRT5qR6%{kTnHZZK|>Mmo^z*AQB$G16b4pX*d**Pc3+SZGn>GP?LXCEieFI$nw$_5PC9>m#$z? zP9nUIb;9C8I*4;gTy@CHg;+ELiQ=0+bq#pC{AlfGI$J}%7UK~;#$pH^mUJ7ZqXbu~ z6t%cdRqdd9j#a{$B6Xgb8P7;MU%{!q1ZifXlhNt$_oA z8b@C%%M9*n$bY^NvRgjyE-h4PrcVrTy?y*<7OS_@>=ZD4Ecu`QMhd$(TgX36ZuB1C zzf)c9T&%%PuD)YYKNm|j)Re^T1Act)^L|(;_6E>)DbY3_J4-*%xHwrd{tD;lD&FYA zHI5ZrRj#P)u8RTCao*J00-I>NSI)u%Zon^fC(oqD8UPlEEq!V!IWU`tQvU+kzgvaf zZ5-A5P&{8Ie_t2*x;fO@ekZi>$lxy8@(PS@W-QC!rZ_*x)BV=LR^i(l z53;i?zCavW=LZZbl=Ba^!TL0DFMrS=1sb$-^4RNb0%Yd|xi`=Iuf>{PtG^amQq3Y63T(&R4jZWTNKp0vUP@k+yiClW+#099 z>AmA1tg5b&(B65_EdLRX(kVy$w}-5&;Mw0If|zr$6N^Gpb9wJ%dQtwGP%}APU)}o@ zh@U5bH7A!cwcdA`t8W0s&lqS_b<<$R0@G~aKJ?`L!~vkhTLEfO0MGvlYs_1D_sILU zWq&97Pt3Xd%Cms3oeuMV&5nhyN-v)-);kRTpgpQcp|F#B*+B(>OT-YX`|B@$A*(5d z?srqrb@^U{YN8l#et(QLL65w{nO>3Qs!~>hT%Km{i}M&>LK?#&WswUJ(~$|{D~EGnoy_)J#xd8Off4C3*(Mxu- zuH6TjCy)M`;;rcU;(JGAP)}nG)Wk7x)G|`Bz7X{NOw%$|N{T#hzs_UA}E-)`#imV?rSW0^PK@IJ{qxmgA!uEV%$H<>ShE72hr!Bv>S5OV+oR*DF8C&I6Tk zj~o{#vxie@+TD?}Zt2!e>p(r3sA-lgjoz5g;#Gfs@c3bPp)DqISQfB)MZ8)8MBK6t zAPHflxQT?2rP;*3F^@)+@Xq+2&1h2j{;|OWn150k!17-3%81Ce-%{M7L8E-Bua{G~9S0YFPN4 z)D&@^8t8!TSb#&%9(rEY_`wBL?l8JFbBI!{o9Xbp!+*-4eCCf8&3E&X4xBo8|NWK2WwmSdXyQ$sPATH^t8 z0HkZ#oy5}!vUEC&FYXX5^%89bVPZ9aq)gMGs2V_V0Mf{L0(RDWKY&a=1JH&_BEZ^j zTUn*N%3DkZK4;78i{-mdAP{qZ3VHW?mc zLm4`{P&9}nw4)Md%LKeF`rKrN35twT;5P$%I*~vDzgVLw5u{0JQU6UKS+zyW#)awQ z+dc=NpHHN^_W>ZGS^5i+O|2x3NJ?LyRU9Y|S~#I}94aEhwo4b3HLgh?y? z+#NlLtA0z0vGU)x^Cu@e+=3;SA6P~}!pQHypqf?dxVt9CsEA2WY{O!y8(eYR-*!5v z0e$P%Qeg2!=rd}RpzG-N5W+<`kf%fTWP@Um^jHH%%-?=cqk=xUMny!s<-w?XL-Ual zU%)YCXKC>e432=kFcKobsK6!_FS`kRL6v={b$G43((a2?zPaeJxP^TIuFtrL0s@S1 zAa#*L@+IHFA!$#`H@4u27xT+!EyZ#LVc{?j*Ya!kMRoJxsnBM`Qg@c(KhtL zb{n^5tl=p0L=s)4jPnZvMB~z}5~-jJ(T2bH|d2Ny0e_t~PZT7ZPvBm|1oajNrC_qT0Rp7wEXa1(hX`N<iPQ#eN(8Hm z+uglJ9d0B1L{Xp)ZyI_xJ3joWFASY|OK~vh{)?3JkSlZhrj_*D{9H?oU!iQj(q+~n zJ8b6S*{TH+X~qIWV!)$GQ(#Uekvr%P9Xn)mZERf%eSEDUPXz=&TZ5t-;7)cEFfV-v z`7>jhTWHVrPar?kY5vqsVxnq*CR3`96{;W1FUI%b&6y^o+W5`{B}AFE8OBmNU+@@macE=7ax_?caWOlXm>K=DjzC5IdBo)wZHp5G8 zJ9thIV)|R)N{2sKxGL(c?`0Qr#5AEk*uLC{P&WO}^``QdjG&09MepYQb^pC{Wj(&_ z47ZsxaK;@Dhgouq42fVV`3=*>-;#v8ueO%uo}ToaAPu~AALw5?(L+N_wAu#ztorf( z>swwIrN`_gbGvX~zBlN0m{ML9bl+1DIpnr;MNjF|l(8>CD0x1(@o_cV<#Fn2V13h7 z^qaS#)6FYD`-{%c8Q|9zA4hhUR*#=gwS)U3kk*rKoenMJ(O39`5PY5U#|`4wrz(se z_16#&_|4YMXa3?t?C^|oijbzH|3RUK)KE+mS3kjHCCv`~HJ0+=uIl}z0RLA27jE`* zyVd)R^KGuHEG$;^dqthGw*T+oD8g)pX!q-SliS**E9QFl@ddIv)pq8L6Mbxn zJ=4UQOz$G5(*{@<4ngUAyxbwSHX9I_Gdtukz?)LpY9_(1J{qkM6DSP{P%};=3Z#-k zH4vj0u?tc@ymEgaLha|q{H8{8jjGitTAJ0hmD(n}F};`L(r4r#$;NRm>7#uU>oq?~@%`znHCjpmr&^ls)%o4waoOCG0#8Ab5BTVh>b3G+@UIUb@p z?O;BxB�bq(=s*Cj}J4tu(8=7(JJ-3Q9+}McQi4p{ug4FYH0jh|~mn_=W36?tds< z+(~Or8qW(#JfpMb_@4LM%WlIEPoB6vQPlUc!y0^pDv)}J%W{A$2*O_ByIIWDv+~rc zDs{Cw3A8T$5}X4+#q~Ps`?9aYkXdxg!Z-d|qq&aLWH5g+<#bIq@{`sZuxg$4%zN$T z{7}VkL-wN#!T~QFw!-wZkFEABSTruciTi&ML;MIEsIeH5J%VC ziS{R-ym-800g%Y>Q4qF3nKzWRto7EaUu9xPB($j9W`P7`7Yy8GMKoTObKC|^P~x1a zbUCS=wu)?{H%G)PkpKfG@7!t>-RdkADdDW;1RCf9+?a1{EIh<#Xw&aq$JEM#iyF#yv>?^wpSa>1394Z)^#RKuxN}FVDY<2W zFUTWyFPlqd;yN?H)#umeKct_S(fO#ySLys{z9{4C1W9VtY$~^t)|N3T#Do`IwKU13 zB*rJt)ln~VwmO^_U9eIps9qfyR$Wzy&gqkaUQ#+6pX+V~yF2E{iWruPI%#A>VPqQR z6WMym^P}#oJXZRt%zz_vcZ8X~O9Y=29Jq*dAiPQ1L`oDg4Xq7%*5nOYEfr?)ih@iTMx`QY zMDJWhpuDb%Bo0)iAl#fmcXI_Jf$>nQx^)_v`7aeP%z$VmicSsSKPDVyqT`$)CTsce zDe<m#R2Q-5NjRtqVaGXX=7ctZX_z-A6mEkbnyZgcc>9|pwHs3Pp+#hdO z-EN-HaFDB`+TA3XYt?SWNvv==Ng5Kty-X?TCM#0FD!VtHOqm|~b`GRsazTVnWS68n^ z9NQK=SsCYO8ru6cl3ch*>vvxpkcIJvz*Kb)HZomJOwyV0j%2Ori*K|$oxQz-z4 zMtmWs_o_(%XtBTbtzq@$Z7?X0XO(6+cmPdsy8?mU>vD^i=ZCJ^?1;n;P$|nq>0PMD zFHYj0pmR4~FTq7D=bR187z6LDXY&pHI~{z;zcPc@>2{eYTc>>YAUwel0P!mDhY%vt zmia+$=gHHsS+e|qT2uLG&1SNO)70J>v|OAY8n`6Phko**Hn;}N9=Zthu@ z>zq@((UFAof)(SLbnsCcx1!QBqUeNWD5=721RX}ZYxU;+~HY0mmfoO$az`pPFTL5)eDE~<^7s)tp(y{Ap9)+;(2hz01GRdU1a?}2TKH1m z%I3fSq}i#pjVFkX$D9T1XB86xd19~Vz^ZF3o7<|!z;nboWcv(4JI?IrEAkxX;}nD6 zH|Lq1{fhnVmPxkMTi*77UR9@$os}`o~y%fGsRy`SM z#}j8Zm{UIh+Ex7(fD>uDY!N*?!*(O{43=mHO+UZ9dkfRdX=J=z*b2XC1lPzM*L(5M zR}+RRI0YO|^HKNFmrP9*hsPUOXqsiiGZGhs4k!sQcbsvSKeZ?^)R2}CCBm=EKBYMV z;YQP)gd(i$eZsSBa9yg`YK66`Pks&4)apC;ai>lYsJ%Y%t-Q_y?H7YXlT=Vt@q1R$JAO{9GG%1hdo75JT5v(0VI!2=^d&I!FAYy>?V&}=# z!7foZT2>zJlzwCL9#AEPbmhyN0&FD3vvo0^mSA8wPfV_(tJnGU`MejW!3AAA=ef2iiQZ%4k6b(f|^~?rBWgr?F2JN zf&Nsc9Ekf~JdI&zC_~H>(a)!%B-39BwI_z=`N*Joz`*ec)Y*bIHzf0e~o*{05)iA3-uA?n=^!ON+Y z&=R8$m-F7O6NP+K$dGX~0XG;irC3D(`Fe;9QjkT`_v<5<;@FOT57aH>OYF2&ZX-_; zBVWDIS7sU*0xD1WM6WZL#_9h1%SK6ebtou~2$2A!J|2?TCY6h5L$Z{dJtkWa{<4>k zwjwefCq{K8U_2ZDs6U=7h5D^GSNfSC3ci}dAw3$mGgQEXjnKfX{D&EXS z5s5bvr3_dfu#p`kOZBI4h{H0dNR~(K!&DF_R1)X6mP}Ik9Sc53!UjSOedz^xq*u_( z{36pWV3XP^%I3lr4^w6=LFpz{kmv~DUu4$qpFgJ1tz!;QIau{($pT+Q^EP-BgrjVI z-NApY$hIhT&h5_>Tp0pEs-qZ?Pz}MLKGu41OQ8mD5F2h<-&epE9AGzi&e@kopy_;z zwJ0@FO0pGxR?vjDq^gK{QGL91CQSQ)T%B~tgo{;#m&%Tu`DE5Qj?UeYr;%gvQ2{r1 zWpRje0VXxG&xy>NAgmc846RC0#)zTos&rq!b|z1!^^s_WJBXa{Z<%vn$A_Ae&^ zwR{K1f$(Q^z4OmR zycY?4b#a++wuy7WM0I1e>s5tN$HQM_DPTVki|l|D>`ECgI9JXF$befn^ws-@MT`(< z&KME>FHCiE=lf4e_DA(f537Gb;vpFEKm*3z=b?WI}E$QgDbz=w-iiQY^ikMCI0lhHYVRaa6alVGFIf2jpGeewYIdvN&LW-B z*y9u`99t!LU!3Pz}wMD@*Nm9F&tCron%d8jJ zOubtQm?_Lz5IKqpEt%RCy9NatP&r}MQnfdKeFfKy9O&W?TU;{G4E1|H@|@P>9o`(0 zhsWiAMz?!Z@M41P+27wnYN#10Dp3^E#L~<5vc7pH1B`bxC%og0i zJj5CLK|}&)gNGlAZ@iFAzo{-(Fk5R*KAj@0#JZhmE{Y@mUroU+658e51z*=amI>&k zmeNwV_W>jOy_!^}Mq50sLIvORlRmKwgrA*kmLvTD&*843x9mW%QSVZqRB7xAw;mX5 z$JmLi+=qQ_7dC-LN+8mTB{Oj~zqqWidLE(_0Y{+%1IC-+TG`)U9~%RZ-i**E1v#_s zV*bZ|zH?&WxtPz5;24!gX2gbhf7vGdi`}%0eDg{ngyYC z9kL7Iiy~P=baj4!?gUVsGhQ`5C2hTO7xI(F+<>hh9ANMfn2;xxKt$;A%?hllpa*+1 zxUv|o@T&MEWc~?Lc5E$4Sqe#e^j46b8unfTOV{TauBp3-$)cx7-eN_p_K80g!;;<< zX(6e{RuKn_ot6x%lvE^SQB@dTMyJ;Sg5&fWG6JqcM8PNwMaS9 z+SFt6=9~l*#l?}hhq}?{ucd`l`~e|*qX)TZ3JfoyZ|rti@%%$r`|U#h^JnGRt7><& zd%Xrq&B~)y3q{yF)@g~LA>_0X2aA6wHOy|?TN(Yz2Ed30bI4KuTCB^-Hw?FW4q|Y( zyYt2);d467T`zuJAL!F^~G zkAo-*K0-vR(&%eqyh5>be&>bJZWUhF6RXG$h5SNq z-4pohlNPlb@294QlJ(jurrzRlk#Z)Sw#goz9?yRa=>4AR+Su;(rVgd=r`I^s#a&r( zr5IL)gEcx>iyrv>%jqbKH1;AGsqghc&I)m(G(p@YTwmEoj`Uu$CXJzS@SA2cXxw5% zo}|NZG&e4Ea+rfR?ON_3+PUyZUJT;gtgf*0)mV4P!ofbi!ui*qk*zaZRMfzspK#)%gqs>Av>f9$xwl@2iW^gxU)0l4^PmvKiHd7l>HF3MaOP`+X(*@nLXmM< zDc4EODKcU0(Q%w<%|2@<(YpLX{Q|PqZ}}i=f`3`=R^l49ae2MWaP**>e`CB{x*;$h zq2*4*3nnK1NI*&rll#Dt>uIH`D`U})V+fK301f#r&&L)<@}FLHy;fzN4ed;tCx~2) z`A{0yG^ylLDPxYsBcMBz35q#{2<7yb zI`7Jhie;U7l||zC#oT^i-eyOyrMX)gk~*`1;u9YKaaJW%uHV6&btY$Rt@VlMhl7~) zkPK7+Sc1q#fN2yOB#-Z5GjT3C&fxS6QhIy}H~n#%F{Ypz{6j=2-=6wh`BgPJkn6_o ztQ@mU$GXOhz+Kvi<4HP#VO~Ep!;wFFbwL4(x~Wc{v;FOpeaN1U`q}+%Vq9a|gD{_F zmwdaP^_(Rxlc0p=oYgh^kTAHV^MSyZX|Ie0v)>zDe9I>XT;IrNva2|xws4dKY0 zn`2MAY8^z1wrTOjOpql-7C{KK@2Yng%{~`ul>3hyKO(M)W5bgNBbw;6){Voa~KM$%VD1ewUBGfzzh7*(F!aiq`*{ z*e}wRjq~p6W+t`L6Y>!QN6C+}A9`+fX&>9Z4addJ^HR`i?pB|T4bJJ-mo>BY%+TDz zbp{mMz1%wwmi{~z!si}X0@PBGBb~-2UhXp$naP8_e$Kj7iPWV#Q}?%d`e; z+2!wT^fV!yVEftAfsW1Y4N?MpuJgO&9wC_$KLUJHLi%v^kqz?!wOzg*am+CWaeKha zv{2)hkRDshf@Fs`C-2SGkTxKli4Rcwp_cM0i>~?EB5{kUWCx_|iz(!>t{6BkV*q-( znZO*PGT}O^?37j{?R`ulyl*`2$0rjIkFo~Kc!W{P&{w$l_qUw~yF3nL4gRUxP9e(>VlW;(r+!nfL<=`JOm1AG!XGv6AHa$~n0~_k$Z4DMr z!kv|c_Y4o@Zq<|e)T>2zmP*NSk^`TGLY3)oVMPkvfvYk}l)|Y<<3$QX%4t;Wk~O$@ zqL7(M#+aI#f_aAmX!c>W*DkOUCK6pwU>{;ZzRlhtNf~O!#20h(Gt`h&HIu)m`DH-m z0E|rqY{xiyOgQ<9$R8xkq4JF2UC~u0=53_6Sh)%Meo$$D$`3|2e2DP?}97?Mj zZfZIU`?f^P)JeQCv)SXb8PaO|(_GJ_dp&LPs<5}ixd)}aefFM2*C<#XNn&P)o@#fU zGb{(0LlGMu-}(&sHh)v`JUzWb7^ zV0E}v@dz9lx1fPOB>ZPkq{q3CaxX?DG}_pEqFy_wPc_TIY866`V^rf~W8o8#yZ;;+ z&r$ed8%h6nY`Wt%U1ZDAr{3M({smlQ_9#qmXV!DpcO&QIrkV6L=jG_beQ$*~;9U08 z+3g>LW!J?e7eeYECgpNF0-J%mcwApph1H)XQJNu3-cUEHWM%vUv})41=nL0_9l}3< z2e2|jbS*YbQ92fAht5-1agWv>ks8Id(M;k;+B_;`u^uESBrrpL-E6@#R+9g@!xHVF zMvyO=-lD^WCs)v__f=CtV8=KJA>402yF^n7zf}G4qp(OE=VaZ=g>cbjyfdbx(L7lJ z;DMdg5(Rd4IFuFpAyMygOMFN6C`nv=s@HYzYjt{UDV`&Z5&G<8{~ZcitO(eL5e%Q( zlP<=k+{f>hM-_IWS?P8oD+BthgGkj$7M<(nWnzNmc&J$t9C_VHC-7TA)iK^FFbDIh z&D&us|5zeA)?(im5ZN(L_o!lxbmE(%bC8%Aljy4kN@& z5A=`B9!o!T1GC|9amkLSXC5-v%?jUTEgt4SJS=Y1J~-KP0k0S zdZQB}C87#?i+L|3C)N8#gVRBU(`(yevj&X!i3zRn3*Y*{U39*#gNOFS$iAEm9gGiNHYm0rBHUbvmFwayRr z<5e0^2NO{m{0`{m?}WdcXv0=bA)CK#fAm7ZN#^DVLm08IEq z^rA9wvH781)0Wt^?$$)9T{}s_;yTV3u$9G>+eH5|LtqLPfRpjf5cN%GD_DmDp56vq z5}4YN_HM-pM>QA(#Ez#zH#R&>Qkp4RQy2J2KUaTx-^ah*N{9R27s>#!dmI>Ys^<2Yo~i6$NhGCUB5T$OX*$BeY8me$gSTmVL0mWoU6_Hr&Zgv89gr z(IO6yv(}FE+aLiiJm##aVJ=vY32TCU- zD@+`-h1>=Cx;QaMj&WGY;%yLsW}iwq+z+u1me;PjG)oPHX0v)lp zf?@yo);jtZrU`!Q^t_Hsfdt*2k-S3Gwuhmnh1;Uj(rvj^Wxb1ADZMfGNzxtda7CSf zwuIW*?2XdsmgTbw(!HO7Fb{P&Mndg&Fl0>Y!|zO&u-!rgnrf(yadSS${d%#1{#jexqF|XWH*jCfYD&3~P{^~< zGc>McED@Eh8xjG-sz;cydGL*ocKKR*EK&DqLOlV$K^jlRl#WSH&gSqHJu7-EnUn2^ zY`jTP{`@+Kjo^`HxpM8iw1%}$4|q+=!X|!AntT1a3d_mLD7Quyp}_1b0bW+jEB&*k zuPUNAVQEOb=9FEdrPS^jS82Kh;*LU-772jen;O;VggnjPk(Ka$qMNC-Wjus67oc~> zK?==hZ` zW7^wvx`=9fW%UE$`a0_BIt=bW{y4VtXF$4>#`j=Hs}tXs2|$~;9J{EnUVeQdNJq9a zFW7Parum*_}UKP=lO5GEc>tjV)W&xl!6uKuN#d zIvj4NSRU)QkMFMra6dD{J|t_&X8x`|JrrLTY2ggTc&MHNMC%DL?Sf{}*eMRt-Oj9| zN|mK-&N4XF1=Gpp6fB^+4;S&MErVJ?a&UxlgA;yEKVotv$-7SSSHfbWp7f`WIVGCU z>a6hef%u4pWW|fBq%y2{A+dz6d4Gq3v-J6zrYJ`PQ?meaLvbN7MzWF<$N?1O+3@oY z_fW1qWQ*$C^*3WMt~uEyW6x-UkMrT%j%%t<$eCs!q{hPSeK0Qk?nw}?za>}6oh9j- zF8M!1X(~!EWl*j#x3B2_>2b(sCDCqVK!U6ZuBWk=tYi=BdV=llsKE5Vxnj6YRDu|0 zXL|{?ci|XkE`F8Owur%H1?F8OU6EA61E|5Gix8!PWjVQ+*VMh{RvuiDLVUBUkE3rWc^guXem*BG^Lz+DCwSYDo*oBuRU-OQF}Kuf zdZ$qQdy)S7zpiPrNbQXH$8Cf#HxXQhm#i-ZKHQrc1HFcT0k$ zit!P#r{t{SWPLc(MA)n7D-8Es0+RV!_8fRxcK*r#hZ3LXL)R^wG{5_0TLc) z%iq)t*>X53BJ##NiVnbcnSQuwY45aOU?s$D)3&=;=Kmh?`Ob0O1Xzvmx^cda?zr#f zb`o>yOYaPC;uZdyRdxAo>T+#IdTR6WoOQhv_i6KvPXjcm(B>h#;^b-brCThhradsz zg2h8rTaNpzd7$Nso@LH^xRsVIl|qMtu!s>S8hw##9>KgrbCdw3T|{+;4jgz2pdU_0 zh)KvbMlfn8h*6n4$98C?T;!Vb(oOH1y=5@nTir#`xG(j_=A<9{XGKfm9kHF8NL=ut z-<~JZb+@2C7Yzj4^3S#lnIJ`pNGkoKKF6a2v5J(lq`L0Qf2?SVI-f8To<$g*QL}~< zU#zP#T-+S?Zq7V|KlIqY5z1Gn7zb!Hwq@CTH4YP3uX4@SzSY+9%`~;UB=mgG=Zx#T z1ydH902=t9(9R9@S3(GEi6$x<$ZGOjdw{jkaJSz#NzHOiRZzja4djaFFKsa@7&|KG z5O~I)rvrG0_YW`)O-gnl(xt_X2|Z-!0d2UmL88o?%AthKh^%zKz64KasF&7PiAlMS zEIbv**+AE{LB4kQL9$X6H%w@fAHN6ixfF8|N6>z(3l+Exh_v9?QFLnt6@{Jzv@Y~6 zR&Ut+qf|o=;I9j2CI7oSk*W>>I_yGHM#kQvXeG&G=YsxxY=LKLAobbCUn7=(hr*8y zN!F^2OwmLY&=k=85FdXs!4)J0ABwP7Lpv4aX6%1Al^)Ho^v zU}KPeS+3YKX3YQR$(iNL+Z_jmq;Xg=kDQOqjTV6vKXgdcosL}>~{92E+gd2XP z%;&gqG*;rsIIAF!UD(xy+yeX2t_?ff<`aXqrayibiP~jJ^b^Hzgdy1&*Jkghq^Y!C zj(c&Bk9%`7-*0aZ$;9qcF#O(K9o`ST5mrCj(lZBlK=z1>9i-(bPC8fxzeTV>5%#zr zmrRRNT}?-3NPUUnd46`@kK8|(rGmOS9zP>K>AA&wva4?K2>g4uX$-rBF#l4$XFAP_ zZ-}{9b^QrbE6z;tsZP4;$$Dad_YQe`u7Y!oux>v`jb@u~Q5td}$xDKEQZzF?nf0mK zdX+_=&1J~pHRhVlIw_4h<>fhik9DGT%y2xL^F*%@@@?q+>{(n7LsZd;;kEpcJK%=tOoTO`r(GMp z?9oX+|NbokV`&S&@oV)NEK4y9IKXsOJj^hK)k|Qa$cJ+SYSeg5O8j=KCA@{_91k87 z#pM)~rGAyr{^qZ8;^c;zCIZt1S*%my4Xb#T5K6UN0An%0xw=(wy32*?PC{*cNE}0? zC67WQeZ5#oq=@bgq*<>Z=*`juJ0A>_lCu08QQCaP`8+lqO{wXpFuS7DcD)bU7 z;fP<7JS1@+$|Q`5s?%h^q*K8rO%{poV}0YGbVvk}E7?4IBLwpXn#+_J%<%Vw;2XJ2 zhcC&vnWCUit-*&Lk6<79T2Mw|iWFndJgFMctCRNe>epiMTsd z>q>db^vfF5HA2QznZnEv31;$Jf*Q;{T9^Bg1ee*=ovpBVym-C!Gn&Q715FqMu7U$Y zj!^Bv6u6cyu|TCSaMJHzLvH*N+ckO*{414tshH4(onZFMFv}KdR9J;}3Utez!l<(6 zew~Unl9e_eEvQJAvht#h$c;d)p?S3Iwzv-fe%OVTeo4s0F z!%8CUcsgK9a_`ocw(`st*k%BSW%z|GKq|Qlvcdf*2lSk(ZU69A10&_d$ga|{zBRSC zL)<8*hF_LY*~%=z0hK^`xa;n1%fBA*aKd97?(Yd)+=bA43wvB9snWS|Mq!sjD>r2)MSubG|Ay-~I$hiZ zg7KK4!FgB@!WYh7DH58lN9zGSCzPq`%O|(i)oq##S~uRbs54_q>zoAd0DG9}Hj?H< zYFnunMzT1%V44LMcUo!7fEQC3te)XSLw@t)x>kjbuSD}RlatPX_K;Q=9EQkE+BnnH zsb*URXS^E80M0>fuxuKz4qgZW4dpp3*l>$>z8C6F7NAm2=#&iz?GEhRz@x*`#us}` zmIuj`RhYdI{CiJUY=en-mbV)U^!Zk^{V?GqPNp`*rG@q{pBc6ule?A>c%4!EH4l(I z9!z>JtW_QND`7~}I?y#R_+UTnBA3j$_imn565%n3@~IBjQeK7~tZu%SXD_AS|I>_c zS#xp+*GE1NuE7)?sT+=-W~Cj}ktfPK;o?l$sA*;${n_V;zs|}tg7J(plg>>|>K~jy zm#x2Q4cjkgVA>#xlb)T?ocRo?52s^A3w0dvXJ--*sKKj+h{|EP&^tLtZVoBeNaH!F zRxa&rAg&0+InC0TOK@j+ueJwp2cy`#T7(v4Is!oh{4A2e!2g68z(lu{P34u!m;|YZ z9^4Cde)~AH{%sr4UN{A};a*I^qT!=k(fgCusiamFRa0^TD`xxiFTx2&mAqK+9FpBP z-dXG?-JT|wN?|Zi#mC7PfpY^Fkfqn~vi5nUB@LNK3Krs#-!z!%6Xq^SZw`P<_gaeR z+K$=J_2|mE0xHN|NN%Lt+Q)P@nE^P;4y5@A7Jkbwo-I z8@2cTb8hwKa=!MG&88Op=4olk?A}92SJkYS`S}Mq_8Hk_qHbd4`*Zy-14T#EuQ-Db z@@ve}8_o|7&1xSPh&KU@4mpopxk9}OQnn?LcMf%!=WmMRhmK9gy0GjZz-Zg^i@ghM z6#&}esw6(+c8=_Y9YtRa#bL$c@4#16hKr*|sapeGtxcM;f*RuC#09eB6T{G%_QxFc z2iW)-1X+KJXXtn5#H{1Jzcm(%s?#Qn_QpneXtdDhvg#bL%?2UN=JC**%T$nSiq9zm znh((;>uoSCE4e>bOla4d;=J(z7v3WgfkSnh(J-=GG{W3r=Wp7$CMOP>rnozi9QaKI zdNY^C)5N_Q@tnn6Ifj1~vu7ytJ13)YNl1l?!-TUaz>(M@-f~>1I~^v?luZb&T*|KV zZs2Wg{;w?~Wv?A&VBE+B5{Ex*Pb)j2XL`*R3#IF$i3jPQP_=05N(2ViRX%C|${eU^-nw@uR6a zHg8Rh{~+uggEWbPbm6vb+qP}Hr)}G|ZQHh{ZDZaxr)}H3v-|D+Htvm$xDl17Do#|@ zkBqF$b1E~R=NDo&-aF{4D_;?Iy`uJ9jb4ER=lMII&wb##fZzZq4f7o;ugK0ZuSoau zw8OIgZ_=fFlCvDvfO}<^VJ&J!b{WL#_r&Q18tx_XCw5$E>Ac;2#{J&QV=qP@!8M<^ z995&X50y9Wm3sr2MLR8J`i?l%jfg7axrmJv(1*#Ox5EKnXG4EQ$a2!3?{kEiCzOTM zx$`;=sVHfSile2L4YLl?C&a{*SjscfP93p!q8R8%oZpvg(MA?<8X!~U{=xRgiIXJ( z-AwX&Dz8{kXpoIP>U-V5;Voy{y>JYA_OQ{o`kZ26rh}?-HN;77jc3Pd}PFg4@P~ zUJ>#YfC%7^X$@Vdu$c45Ph%?jZ;WrrtfcjEgde{NJk)jFQ535C)VJ~zV12Kh(p>fg z?{g{H^wqxN=%Yt-`WwF*lG#eN(hTF4Yu}ML!LoE->s>6XHi41(EkHfZKVe0ZnDomCi5PJT#kad>dF zKwI9hYY+Gf(#?%?eCQ|NpoB#Eb=vlNSh-1T{pNxj zh$4he|ENg|BI{XP7Zs?f>dWA>+jF9T0?&r>Ze6Qr@aa@F)0aEB-H;qIMM0B~a7}6g zV}3E=Bfj2^)nH##27O_}hO0A4>ZxOTweVEE)CFj^!Q4zXyA|*FLw18_B=Ni(wY8j-s^*4?BL)?2+nF}|e@4M@7 z!q9rqqdQ3eA&M{-U8X{kLyinmK)ky9p(}?<0E3E8N|Npwa@Ru1mG{0}!tau4>#Z$w zIrmo~@&F1}nggwu-wGVD*Hi5*@aof>Z_`cqWM|Xz!j$-Zxlx<)S~yTVaVt>VSoDHA zb98KVmOAd5`|f>}%Ow(f7e7|o7jsyc5_X<8L_dq`m8?8+t~hOWn%f^19oB~`&_^zT zGWZXPQ+#p(Tp&if>4~pTVUHSm)E_D!SfP7C9r|?F2>F6P_eZjJXshWlIoe$M0zW^L z)2{*lK0VG^O5k|(@6Gsno7EVdBSBd{Cx}q1j!dzPw)M}HS`GY&f@KXPgZalrm&|6x zhuz;ejD7MV!LL8!2V*f?8F2>wX-JCcjc7Q$V{Nn-*VL#RG1p7?J#lHy1TlBEQ5=t3 ze0btwsO^KNI8lcRK5;OYBrIojS>^`%+u{|u^cj3^3-Sm7k8p3Jth(3Uc#sWZo|wGg zkh)A5?t`x|5SM6nPV=&m$7YFB0s({MHw$$RUNSEok4w~f0z1N^#|llISFd5gdJLWy zzw-&^c^Nugh0A60ohGGW%x{;ey#VAE)R~$Kbh6JmUr-d0fv4S0Y+lsCtg@)_g|2wI zR*FzNFwz<#(eEw{%=uxtRydrp^%U;T5F?Nr(g9CnG;P)x!w81VgfN)Sr<3v4&@ri_ zT<>U37(n4XdSXs^nt$a7hQJ_U4}9g4&Qz-Hn1^+OD(#sFR3U<3%1_W+!g^@uvpMl7 z0+p`|Z!flNrzGEk@<3oA`&jfLQdlf+4<7Mm%-p_E6ulzuo@`kl_To&|H)xD-OX;%y zKo~R;I2I_L3cBPx{dv({QND>SFRVl13=f>vDf31z@BZY1d<+=UoytG{=pByc>Kf=i zf5qq%#(d0+KIPTb75)|o`g_4+j`*+7a2OcA)Wsd4#Pi{r9Rk2ENZ{8KIC*hoRvT(` zp;ElVH?j#;DDc%(o}rO$z3@9#-yD4(w&Y@c3;(k^>iAIhmR^BRjOm93Xs$JTkCTV_ zw#-Ir5UD5_&k|Z1Sk>-oNsiFK{>)ZK@10lL^VcgxPwQ$p8Ep_7&Z9cvYc=9wn-5q2 zFOOS%m3$?Qzr+w*C~GijBA7!&AHVrqH?cSHsZkSx^GABz;&x{4#}+41G>a ze^d;F3I$6Hu~943aznAGb^sBx=sykI7$G=hZbmVUopF&9os0_d7eZSn8LUlpd_72C z8<7AYmnM*2A@$Lqr~AOWb2_l`i}qEM#WBfWPxkt5CV80W)7^ZALO?q*naWP+sV$of z1iK@G53Q^uP^qO?Dy|<;6IY+7S3l2oA-D7@8bSo21>twz`X9J?AIS4A}#( z&{t?Ns9&?lUBH!+crGCf9_!q?8!xB2U)`?p*rlF3d_EqoM9reE+0ga%!Is6|f%6SU z&ZrBPz+BP&p$}YPvZ%qeoX;A*sf~GXIYYx3-hT+L#W{T7-#s$Ew@LyG=K4QwZ{{x) zZnz|ABR~R3bZ+qd3i~lnKr0*L6#$N8vxEF#Q=L2h zo@sqGPVR9(4$To37{5-ZlYL6&$n*1jC)+!y4*zATJ?z`w_(2)^nNJJZ%NF(>_H}Z_ zkGJ=A2E=O$4fdWFQaY3J^Aw`z3p}`ydVOs^c(3}_tts7mGiLGp3QN{tM4_8vH|p6O z&rlkx7l#TbIH;^VK@@KQTT2AO%>n741-`b2+06&*Xr~TjBpbl|H^m5iEr?b40hk{^ z6+Nl-@?2qmmBj2k znH(=ZMpXtS;K&*)o?HQC6VZyTXt6@yLcXt61g^0_g#@S-zL%7*^;y_o8PO;vfb>_D z$Xo}NZg{|DD#}NBz!p8;`e1&o>%i!VRNCoU8Eg%q?dJ)xG&*yTFPcSrdABgOZga^t@$FUgV(hur0%D1Z=2rRz zh)IY$4oEh!?cVMEhCqUwpEsJ6oVByd6vRcCB+a1Fxlv9w&@b9=enWmyXplT{G9*o) zXWV(+&wceQRQ8MD1kHG&h$|LbiWXOrDEJq$ogYh;^fk5^N(;c(wD=QR9R{a>Vi%HW zZ)*)%GDAW{wl*nYYFCC)2Hwcq5KOq|JEjqCqu}Lf{5}kFCfs%fnl3|;DL~!&VF72& z;5m)2%-Gu8%G0=3Hzv}~^%+P8UNjqcoSsZ;L2eQkzH=V0l%$*mFfy43`lg*$i3uKU zcdeq-CF;ZnuD!9>IDVfv7)p~9d!|l-6OwCAq&vVEVI)V(Qf;c;+j6dRhZsL|{j2_l zF(hkWcJhSWz=sQZ&O@oMz=9%t4Wf?v*QJ2aCLx^X%m^(DZj3ip;^o?I=pPqIbw2=a zn!2S{F>Mrus{%B8b^j5t$Pui{wSJihA}os8wAoyo$65%vJ>4QiAsO=aLaW@nH$2G6 z9T9>I(N@(=GY4(eNk#^KZ>N+RJC@0(5QJ&SY)P#5CB^7z?nDWOh=w<`jbYki3X`C`a=SR+Jv-y z+|#D5g=Z20G)HDQ2j;-HFgybo$e}_y5d+I0&H;$_ zhW6i54tgHpwjlWq3b68#M~QMTZ-WYiSNMt{u0lkEb59^aZVA)Thh54{-|QsTEQ`#@ zLK6pt3DbWi95p{r|`^DKg=k;N#(E_=n?+-slB6fx9< zhLRd_-Mxo2=cGUqjDT)%n(V*bXOGY&iUUE=PuXc12nkB4b_fXwdC&T5Tyk4Y;U#6j zbI$ozY-QP_W|aUaX8M0S$&1~VtSwT_!fgd;&%m$kau?#3eXo!;37*nV8WrUtH9<3D z()O_f%*Qo?l|I5E8725_!e|u9@9={osBwr&V;iz%Qmee(-4Z7>$1Y}FlvHH!xR}3F zt)F=1iG7i`7gTWL0_RLnqCHpBC2I3OWT2@QmfR^2trB{&4Vc3OqT6P9e}WY{S??Ce zsdfi4(M^u+%YTvu&Dy6YNl1)G>OrscW*1_?U~@*SP)ZIzy+&RyfE6f_i?d?EOq1*J z91Vw#Y?}rmLuolJ(EKz{?^+p-jVf3EaEUPMf`e2Crw)ixL0`xMQzLT(lJxaK*c>EI zAoL+1Cm^S&9&LJJJKtL=V4&h_zg`DCS9h#+uvgt}2 zM02)0!;dh7Tgg#15;%?)S+g?ljbdefRgH0n4mAv3;cq#6IJpDH`D>|vUk3;m z^IWnSOoLL_lHk&6+Xzsx$WaO5XlIBo2bqK5;y$ZM4C+6#r}SRd5czbkH$1Z#RLzE| z-LMTS#)4X;Q;RF(siXswT@$%Q9rAtNuw>iN*PhyiMV{AS(>O{QmBK4vZ;?ea+{KG) zZ{T&%Q7hAYOkt780)9tWniUzzs>+v}i%>3ngl3nLI3c!G0hdE5n8}rpi)cwwEg|On z4XYLyF=dFOf!T%0k(><}31M}SvsXHlo*gXFEDPsRv4V6&XUc3Skd#4lN=K|_=jCL& z=R&Ocf`}m`No2HMzW3$k8B?(Kl)BY6r$MGgf(0+#VwM>nT{h=3hg&@aM6- z(@Px}Ygf!)SI?hYC1s~Mp#d5znT164=V6b8bTkb!i@4XV04L3HV7W3?%#vC#ne2O| zOa9ibOqYls_=k`^Ac>ah^fFn7$LqU8vt%XS-?>=GUVs|6r-Emx^B!}-sUUv0h zY3#3jbQ>=67YBbey?jL)#O!fz zgLbLT|9pY`e97$G5qfW|IUV3$bieu{{&)rbT>AVVo1N7p>7C12g-t$1jx=mf16$q1 z-M3{EE14@efGfX)Yt{srS#*Kb$C7zKTS&$%sYvIRt53_(p>3odLX^0?Mm{F{8i=H9 z%dsxJu~Oe(&RYCxG(J&u?fIc;>Ar377KLQVqF#f%QW#hJHCJK6HGr&%%fH;;mnzM* zOUdvc!9ypLApY`{w)^e2q23d^{FE>)t7^1<$*b>p1LlfA_0;uqzBHr2^Jx040`mB{ z;DbsXklRsuNT8d2GAkDrFW<_*URN=F>&0|`!|Z-L zdck$~I=|zo+}hreEphj7snqkJxaK4bGbcZ*Z*U$Lr0;$yFMDUCpl8>AZFbe05w=i{ zUw##;KfUrk!2IE{XS;l3D#RH2?LmBF=S}S6gjA0TZZKYlr!vioV$SDANp)w$Cw@kE93PWAs?>MC9&vv(Y`4(+k>E&@)*1 z_qm?oM#em~o=V;TXGm?%te;wIf&g5=D5=8`evh_}v#MiQ)6+@FL zNs*=t8Y#mFktrPFKLS4Tl-_w)=DzYxJ+t9o2ai5lVtfBsUD?<>`Yres%-pAFPI5z* ziR#B0iT~=8hXbNTB+yXZ&n=QHeN#dh~eu(GXS%hQs^X$r$1ksc3p!@ z&YB(_IoSI|{38$kD@bYagYXu~iav_Xo}+UwWD)HF1?&B)wghY4dV6u8j;EjYPX%vF z4MVx~IVM`5H{Vx~`mW497yQc6{E~{P#+GGulE^}bBU_>_HiCY|GuM7JPNj-UW^l`_ z8*o5^zeR1T*b*X>#%9Bl2v>^Sm{?{~+XCRp-)gh|{&?IpYwadn^-JE|QLBt;#%l+d z(`ujbjpY+=RMfjL=3IY%;bBS~2ziPu!OaHd0eU)Y4B=UI1scP~LFF8~r=h)J(tX)j zKb=0@0#yHVRA|}r|3XSh_j#7xWBydJwO?hiQEh4A&Up-y|2DB3VaHt9k$wpn(Eh5} zh*Df?hG;WA6_-wyQ)TzgD#5u5wmuyBpzxlTJW$#+5T+jb-p{XOPY~cfq<__8xg^@HHn=v9(Mt8ot>*LmUT4N8?3TF;i28+?jT(r2}+gJ}q#=|3m6E8HVTWYU=MOMHdj% zJF@0QG@2If)wAy?7(Mkp(<((oTF&GXf|FPR2Tk4!xapHESwdfJuemA;zSzK_yqGc} zN1m~-#H#*fzurkDHQB0CSZ;dbTS5J}&+-xmS_9U*A;p4D9mD6!Sz_j?F+e;_0b?@l zAm-+Gc}aP!#X~IP&w{Y)nWulQgTn8D7QoJfD#cs`Lh*EWF;g!6ilodbUp3!zJu4X& z9Q@0(kO%w)C)SCA4e>743>2u7QS~Vw`uCgDz>_P^RuVYZW-ocx6Kj z0WTmf>4f>|hNBp}Yk3^!b|xs2K$aU`XZfXV;*hu)!rBvM38+X$*2xfR(U=cbT$Fz; zBT(YNBCyKk*YaW0%3IOm?(E_^cJa-uHD>NcT|B*a9y;k<98Y5UzSSf58cxP4Dhn-Em3CPV-ZI(WrDVmugU&$=RiZ6I?&9;pISoCOe5vy z#DAbep@=JSIa9n5jkb*J&&A)D?;-CoZC|v`!%r(Xu*%idPSk=JYM3OOa|7X=-@+$I z0j*>MTfg`u4gMUdAO z!|mA6Y1!bxSK2bMwD;o(Dq|R> zQEcGZa=@8rnbN5?Ldy0I=KLf7yDUw6a7w4L*Z}ePCdFcvcXPk^m>|o(atCcCrjAT> z7hSMXJ{mc*KJ7{6=30!1bQlJbW(MqmWwM?+a%)IC_?o7)9N&WOpV|G0JKO0q;m`xa zg)dEixVqHc``j(;-H)s6lR0; zoG@NiixY%g1lLAt%*6eVq)T{o6%eR1STsJ9_4x@u1#19|43SMg!p9avowDrH0p zYf=>O_rE-#kzeW+vw~KK5Ld|s_NglSgSI{AQFu-$$+9UU=T$iH`k%5Ul;#CqelMg6 zL9w>vPq=7Wypn@Q1|Pt|EGy@2t}* zdHO58L$tRXr6vQ2%SJs0spM2f>auh~K9J}!PJr#)dX z(PEVWyq$IQ$aNN!ccP%72xDmi`S)%G7Gu%{-Vk|fKMVlPxQZhmw(zB#TzL^l&UH*P z&z>YcSLH+W+q#XWFAVk}T3&)9E@B-*e&>o#zqCTRiyCE4HEXg_#$!I1m>n0kXT@qP zJ+KdptCS3=yj)iDyAU{;vHLQ5*;#8Dax5?zIGPyXsz+*P$fJm6IVx$GvA3>~ZD+hv z9$VI}e4QvRo=FyLUzAPWZZ3NgnhpC1wQG8MK5#GEOec5FwL(L9$1WoX(hC7D2!vfW z!J@xyW&a1I$ee^2K|M_Ki5Kf9Vyk9e?Z_hw*l%uGH-q^8-BcwOEg>|+;g}Dbz?E{b zT>2nA)w&S{u#I@fZT@-L!3)h@{E{f?LZshU8Ksi(MUd`OlDqzHuk|P@M;B|~X0-Z^$5r#!MuH%`JRELk&maOI7C zP-Sp=Nu>1z!4b;`YHB|S#Hv5Ewsj7l&)MvR0AY-XPh90{&kmaN)N2dG2qd(9sD6(x zVzX{H38}`%uZw41m#(wf9CQYXo*1Q)E%lwHNL0QT8+Miwh>A0-oV$wrht6-jTG5oYPPNakqsS}ZNYO3K+R)u=ULKaZL8D+aW-1qki{PN_A2g)DhBO}ez!p3 z0jutXtQjmg{aut~@g|J&I^5f}dZ zudNFRqqElV&343KL`)CD^mm_cQJ^Cwd8s=8vAY_&b*wS@j8x)MTK+KN87_V-!Jy3{ zQ=5<8h2irRyo?TFq#J5nUS5B_;R46&$tThYhD)4TIrenFP-@F_Weo)R5cfs=Q?L|e zTHH9@;9(Ie3ic-08G+ux@pGzTQp$4`vr$J2qKt8x?U&s{D6-4fAt%0vPYAS?`_?C` zn(M5F>yA!q-vOH%4bi z<)LJwUKbZSu3@35$<9JB1g%p^`J-RdG@?DZqS= zrf3!pg=GnAlUyx%9WEA6<1Id|4*P?lgDO* z(0}6Q2@3=ab_xmv^q+&Cs%*jr6H?!YM(p#F404_KNc0_1sFTRIfift+QGMg(bdXvun?O@&)=G=fg(`^H}P+wvBqeog3U&lg>#$1)D-56Lw!-RulW6-CZrjU@~^r3_ka1$L| z1_p@}Nk?RF+{-(N6T>mnZa9TO?ORGqA5;KG$RYABga&RR-X}9QXV)DZg!U4kk@X1* z^^3YU)6jwgwZtJ$nD5k=SMM@Yj-)RI*EZCns{M9}k0O72mMo7Q)P;0z>jJ%}W9frh zxRDur6-5HV-Zr9&6ux0Kq`LzWG;TIXBD_#l46>9pB<5x_>if#}f(IWG^8=1Ya&Da3 zh*`yHdnR`Sl8|V_$S`tO>E-e%q06Uv!nsUnk+fJU4O4f%UqRQjf;v{p>Ld$bV#<2p z@t2}n>0=TxB!Jkaj*wR}e&1q@O+TyT$I627<;Lt0x@?<#4x~Qd_j^ZlFE#|%hNR&{ z%w2Z>C0KC+H0I3=kOrZ7-;dosW(h2?eD8`+J=g@q@9J+F4P$V{p1}uI2%oAL?+RdE zw1!9EbN1VFAOq93DIwp#H1ljqv=p3wRbXl-X&60dwfKioPO5PT!#1Vj3cDake1)Xv zk=7(Cdj?1irc};F$5vD{LObix9oL-8%=&0MgRd0qE+mM)V2o(B>d>1b<0^0ACt+-e z`u2gdgEPpLnfpYaq929z9S~&%Fma;0bfM`Oz-bPqRW_^U)byP@Ck;nAKec95*^8+p z>^$5W8Nt#b6Al$XQ0YI5mj)|E1_lE1`)AAl8yi~Q$i~dv z%GT^ZO+J&O#h~z?{9h(tmeOQDOoSw4v7@oMI~b3)(I$mmTnRv-R?jI@b!&4%L&r7M ze18eU!t2qrV|^R&xY;JIjBlXa-0f5k!LN+ab6dOK*#vZjA55R&w8_NuEkZ?{e7V0| zx5wIXsN`0CLl9AO8mO9jr80WAN??O{BqHNN|7VoGJ4bq&VXj07nMZxYahRX=0t=~ zM7u5BXjxD=80~z@wcs%vavB~5@X55wHuhjO=yRJHpo4-L-k&(7itEnYC2GPTnV%dG z(}9e^84$$dSyNY@B*N$UFm^cSqF<=Bd@}e0{kK}Hd>oY{!=|xdA%K9g5P^VT{>zc5 zhzpC!|9^gj{^o!5BXt^j4!E31zLHSyw2RbtlhH6$~Vo52f_hjy|(6g&=0x#xxHKgq8h91 zy)PcUf|A4AU#DGLB*lxWUDUzuWq;I|eiw!*ms+aPoUq4LN38~3rVi;YrUBH{E6L;X zlt*i$c{l3ZZDQNYWC)hzZtz5+=!03pC>xq+N!3d=&(+e;;22e}cpsq>g-MgCPq%jc zeRsM`9$H!m&yaVml+KFY=zE`ABzisB*-PY^AR@ROYRd?W3 z{SR<$$Kb_Y5bmad(LsVUgm=nL+bp{raD27m5c1vV@%Axm;p!{2uhF2N2PIiem*>aQ z3B#kapom$4idyN)!>oS@q5~v_80H7|k5h~_P$4A1^)If0fjx!K)A-ibm8G9$cbmY| z(Z#!(LkswHu_o+SlS&q}?5`b2$S*gUtX~3&B0rm1Y*J0#)Jf zRg{6xIIbdb?d`o2&vprCfigA(;_c`*Q0OJTr-=0{5`01rcV8DN?zHN{%9`ms$;1#j z)nbceEt4S`Y#wSmqr8``Iz5~!D`m1d!=ZyIFwXXkI7+M z%BPfR8Q6Hq=X}Z7ndVwj&G7@2k8Q9i))IeigraQ^PFO3PQw`u2^M(ZQIQ{>TaJ5tK zy)EQ`q3Lj{hP`z&&=;N@w#*2;bM~bBBV|`WK$h~vxREEdOVyjL9e0u1S;%I$y*$I% zHO!b^(Tx0(w;R5%G|6+V_#62wPcH&#@F9m8W#mA@m$7NiZ)(1us?$6uB=r?{Y-nE0 zK9f~+1h#~m%%KWO+<{1}U_AK1;@+H%b~Sfg8Ec>ISdt#$MbYf%nKiOK&A|J ziLr+0K54eI#X)}Todb6EQa1(m#WhlhSNr7$<1l5a+J z_`Pu9;8fF(fA9x#Lw#gfr|j)w%jdiXl76JHx3;U(_1I%G$`DgZ&sFR`bDDD@JRxbO zH2iFh=~glr13}5M3C;z5H|0my-zxYreCJUN&koY{FMr%Kq7Hm%$Iar~Nep8%Cx8IA zhIHZMMjiR@v%=k!cnvjb7$9vtTXLeTPIu9{lay3+JlLdI**@QMZ;20>dxwF0af3v) z!tESnjs7r#zrTazkM{@{KYzsm%HlxOo zxrS~0li!^bU`Kz$UY?ab#Va{$--y3@MdP=(FHWC34uLsF>KWy_L8NBm^a5nwB6FpG zF0O6{iuwZ%d8O5UA-o%Oa~QlGK#)?%mvz{Kjb{+8{jl2jV+hbM!P6$=bp-lDkd)Mk zZ893@nm_UP{9BEUSc|l8F+|6I)vu3wW9sf-?WCdjQV{lUjf(xopR?+%WP>d0gSQP; zEHesK1&M#X?yecXTJiCI!`ELw{Bex9@E>l8z{CqGq>(kzp=KS;b06Arll~QM5yvo$ zPmMuEmf#WuPm-PM-!Eu2qU5X1&Ao+2NQ;V3_dqHvaX|j}z&XAk>2wh~;JY}wmbV3V z;0^M>!--?GopQn_pULOH2%U@u1cdQl;l#zr&e7J)z{=jy&6UNJ!PLn0|L1b}AC{=i5F7s-=Iv z<4!K+MfkO4Xm$1N9??{>_uj%JW0JPBC0p+~jJ&YRWQFIa)6^!2aZMBRP9M<|zTXrI}Y?wHfcx{uo90E;Dx z^8G)uqdDo(1;1#vO7U(NrANDyn=vjWV75ciy56W<7nM(c%Po%VU4Hj%LjKvlk^&CZ6<)GJ# zIjczSn^AJFi#5N)1k^{Z}i1~F-c zyh!r%j{U|Og*KuFbaUOjOvgC$C5pW{C|LIJ=uhzin>$eib=2XM&Au7f!~(`dF;_5b zqB?VCRLQ(ZqP+Jp{!g@l!r|+Y$e!(T=~8UOU?v~+qRePX^nsRhq(AHR9Bp#shR9g9)(6AIXLfxH%c65D;Z%0DiCfqM9<|{?a-hmcqB|K zPwlDiQtXcbeWFs36jlZO@`1uLXCqYepY-4w!w_^{J`qe)OsC+WwtdS4-!kI5{Lp>Hq$HQ=h!_V|(cni-Z3Lbc&E5>O~ z0{eCy)?1EkU3)Zc!=q;sH4FHdCAb1mUm1jc0#3_srOU@Dzp@my^#rVxI|mUdF1&DL z|Bmp0@w@XqGBcJ(VJ?rv*zD8gI5z#sbwh3FD*#s*^3adH>7d$ia_T!E@f)|zqq4D( z+g|MxxU0G&{Mn1dycvn{*dOI}dRFN0v;b^JY23_$P~Pw|ZhPqV+;n*EINkM`JS(L3 zvVPzGyzS<3`~15ptHtB^Fpt@XF}H`6ar^AM(328i4BetRM3>GKWhP?`yFGgU2QtPC zV4T&Wc}y1197CHs!pyjTYF!>l`h90y=}kVP|E6z=sbL@I&gxq;Y@Yd$YNU|Gm?4v@ z)%CbHf^?jZdW`&sQ>K7n#@hT;JA{_8ogiWA2l)T=C4SA#D?>OyKw;PavoB%$fBKR# zJuBzOj^vM(sl~Oc|=t3<6*Fz1Obtbl@v; z^tVgQ*Q3K%O>gM!PAt7N2fa`mN=|!S(Hq69KG`v46Nk36>h0e_=?ZmQj|6lOI1PWp z)>ItnpT4O80sC7Xw?(eH_Vw+W7}jyy?bcHkrl!elWIM$s0Z_5T7rwn^@&#TG@r_;&E+7G86rc0NI$N3j6#f#ar!N7k2g@-E8#85-Ok-V*@L+g zEJWY$A12=q2&5hP0sB#9Ww?Kaub+R0!PN2zlP&cFwaM)rQlIME6CcypHc4yL=$KfA z)h)dMuWNdOS()&5Lu0G&dqZwe8?{?PQkA1WQsm}=cuajo5PtXnOR+`?rdf-1_G&ex z{^>R*{^@oo_c|KW2@@CHFB29WundF#^)D|0q$u%&-Von+Bwpp|_So=RvsUft_1R#a zK1DDMhkBj`Z(ARC`9fmg7>DpzrTEfgXWM z{qMQoxKu;v`+w~Vp)w*Jx`SABN&23wh z7PgpB*;^&thvk;$NS1$$DY6?RdJCD!^T(7Gdf(Saa2$ZN9YvX$-*nuOPIiG%T{m&p>LXV*u3tTWEVYdUfi}+&SguXP1d#FuqCuZ*>zsO?if~8&1pV- z!>aB!X4^5MwvNeqOQNc-F%wEFx6H?kOUI<{I%3;8pf-=_BP#2j8TAXL*)lxKGVU-K z-Q0vc+D0N1eie#g-H<}Nq}@1J%P?v)8r(dH-I^966Mp3z?r~YvyYme9bZ3Vgb#Rqv zagR}%VmLq|8txyED-G*Vh_4{(=6}OL|lHhWyD>Ot1NQ zIAKW-gkZFN3RKn=-eC;DfO%7z|{HItS}Hn<0J58sEGPCZh~bspry;`MetwD`47b|-pgmT^_QH&a47+i3_I znbunWo-;b%e)k5#$h6irK)i)frN5AkpcUh+WyGdO+G^}GZ544He)kUio_0XD65Gnw zV9_o)8|ztULXmzsPD5Cw>SAv&ZIzhI^C}A__r9K?MXybAvC!8WxS37x|0b?X5|h8Z zx%&d{@^P4!F!+IT#w>);73kb2ShqBrL%W%fa1b91{IQ#R?qM6`^~P!tIb9^rq~x5- zxil&9SRa>=4f^e4BPCH2MA1RPp$)hAksk%UT?T~u8G)st8fch_bwfCDsdAZ&YZ;{% ztz}$-?oRzHDh^|v9Ge_Mm!e|7`CkKI?h8K#E-kW-qo!@6nC+kev%bb$Bz+ex=iEya zy*Dk#J4cha#i#`B$S*&1(0XJYS9Q5oA=^pSrlyyuI&K<{SAiyWL9?IV!BaM)F-?Oo zHRzOMV6eHre6dh#nYEpbo-Na6qajU#$T@aA4CN|^%mxFPn_yCYo@LJk>Csr(cILVb znpozw6U>WV_RI>~nT?Iwg^dGWSpC3h;X}gMT}@##B6O;|;2YUARF>@mUt)g`OwoWE zpV<_*OD~APmZnc@z}A6P>G#?1WfM&v)dXQ+k)$_ZJPU{}-7kaunBgNt5ose^1(JJH ziI;+_N0MVCVQ3ep{Sw15j8aoU?i{B{O^%i_iNXp~>Lx*9#vzI5X}|eAN=mIB2E49n z&@~Zzi%#2r-b@Ez&NYX|2O<2t2m&%1_HhK-@JN6 z29TlPbBD(zNR(tnNVz01T07Wtfe2|4;xEL5w7tmY$ScB;pv-(PvBTH|@0B_ZQ9z$< zoqTbf6%jPT|1tV>g+8>0Cv)ES^mPT!3WRb&z?1$fi~L6mQD8FmXt<$M`QWm@-I2)D zKik>8?Ns5k&w9<79!>A(tB?n}<~YG8pfQdNpSjx^aFMA<$UR}Qq)SyL8YLrrz-kXc zis!U+w|>yG_DeZA_Q2>?d))IG?c^j>kGZmAk{OoSbOvGV*G0!RS`&WAi64VK9Hb~R zv--(5^l%{bNI=A!pXid$CMZNufvjlc-iqTN6FzH^4u}L&=gT|nluIPBpooDJ0$9N8 zeO1CNJZWBGT4Yqv&0IZ!F#XK#YwX>n)8;%^z_2Otvk#E?*q4cJ5?P|*J|8eb1~a)7 z4?_by{=+g-Gh8jRS*G#jp=ypL?4TF zr;%@jQwsk|_@EL|A0E?1KomIg1Ub9ul#;bRu47P8`}M)5k`%`w zd&aSrS{|BUBrVakbykwO0an2!5aY)<9m%F#TrAdQkQ`@;4wbrD`N&WV zN4t(#7ggXe9xmks`Xn|{`5-C*4)Se{Aei57m0(pS?}I>;3N%Z=)Ld#1C=~ol*?gqb z@Ecy6`omo4(LgE~0Vd@XG8EFmmLRB3V#X$qrn=XnolMZD@yPPvq+sa|} z%r$-^xW-sk&@dr$1?RzmVl3FpQ?au{y5Z6Qm!H@NR%c(WyO@};bP|*l z5X=*WT3LxgqY>6dY>48*x!wTtf^nghQ~dS%(WUfap^c@(JXhV zKAANhL(8LA>=ZLRT7J(X$Qzt+sA{JdK9rOkoarCZ^xOW1@K4|)T=H?1)RCt9rDeW~ z>HtwxCXc!OM@3U2Pbkai)E70+J9SU}+L zjyFeJ=p7_GynYhaYwi!m05Wq!x`j^KD-OH|Lcv`GQ zT7)Vyc?sUl2}R>?qP#rNr2fAX6}FrR(#Nh6x)fvIHHoj0tYetR1wJInw8kmi1<{dy z$RwGTkGOem=GbZYQv#7P76Wj=A~T}fOnsu>$X0Zepf$b3j94(Ca@lT#q5Yj4V)Xg=fK+q$rcBgnt zWvbJOVed;;u?$o0kGW5< zLf5z%{XQk^3Op53yC~bVu-MG;`ZQ3)T9l~|B(04#W~Vf z+HcAv^)6=L8llI|W(78*LrW+Rhj8bx~W({P%4tI<^c zoRndP5>Z9GUnv>mFlLT0HNdhC%Xp-6ww!+&Crt$-M^uYO@jjtGiV}DTR)8#5S>!NH zA`leS4gkZT<1hh;?6Hu+8GaTu@vxI!X-X>aLrtO4`Cz#>-3O(ZHWTC%HBu?iMLlVl z7X&^y9Zw6mT=tW~@2e`gNq3byODcIdi{wQ2GB2u{)G$k>$0mr==0u@5AfC`>BXL0N zz^}UqbC_0bCFg7Ms$+~KR|8KOf3!_G?&9I6obqN6l(zVANm>U@<4ykYv5_}*h$$G| z#lgkb78HqHVrA6_RX=jDY*C6r0EXdXUJqsp6^ncROR6w`QfLi}8rw|j*os8F znZpg?27z1Ygu2UIVh2Gk`0$Q89WM-TN)CiwsM>?XAeRCqDL4xAAW0MK`tUFTk=R%Q zHJau~7mm#o{mT@`eJzFD39S%VV|nF{1vVTY?g}w$Y#tXz#u{V)$vGATzDUP%_AqBV z@Re|(n8|!g(@_FGjwW_0PaX4F%R)>tkzsgZjO1e(EAXehQ&G$mc)YbwEL@9A$OTdQ zFd$^IuZ}E;_`U-o*RCz1kSg4<@|)NlDsP0r*3B8~&dKb~auZ3;GMdjPwd6$}T6D`- z_lva{h#m!;xPH;UzDUvJ^bVb@hFLA-lF!=2r_Wya?uwW=I_m>LPGfSXTq8 z#grh6CREMGQNLrA)UIq7Gp$q%v`0VAi(E-0q@9g9@j8@N>TuDY;w0>J0i3Qp?wK&r z#f#|o!K{&e$C2rcfm{GvGtM!wW{}&A3deIpNs*Knjj1@M;w=1UcE#xFe985llFw2o zLr_9Tqc=xanu6HdUWE~(96~&B`H^a#NZHGPnxE}ZuW2gzQ>EiDCmDEF+HZiCfe5q} z=!*X-g0+Yk53aHl0GdwJ&I*|zC-Z3D!}$G^+NL%RC8x^Owpdj<4dHt;l^0B$7&vEs0Z0Taz)F-tc?*69^7ADh>BtneuT ziiD2OV#+AntO#)~sMJhqXWcL&D+owDncZQJ&(?t5Rq*S806kdw^4_b9*ocVtAYMJgsK z?$fB7`K@OnA1k75t{LSA;t2)GFUuH(lf19)IT#Xnk4ZV)aE5CX#TFATZ5T;;Pv)MB zyNkX>87D*a@J^tdlMz^klSi2(jAMSZ!UMjo$PeDTKwi9X0Cv>7IvDVjzfui?J?{uz z-8|X1z-dZUK}Yu!R|>5>fMPuZhF~~&?6!%}1BrlP`md3OK`8FwKu!Ka+?+9Ml(d9G z`wX(x8D0gfkEY0Wm8@JJ5r{ccL;e8DVt{PtpW&3SOsZaNcTB4JTg+n!f@*B;JC^4^ za08r}7C=qv28`1Su2Up<;G=q?KO2O?D80>5eIme)?e8?u3IN6TP5!Qz701jYtmRGne65I!n@M+8nK$8Pq!Ud)J^XsdK}8_W2q82HrNPg6 z+nqPRGCcBqQiFs;p*~BEl5L`K%tU;EXLC24@R_2Bh_Q)y2 zpaia0gx+BkHPnb7O_FOCQzh0KPcvjvG0+<(6lfaqED7YAi3!B=X$#4pzz+p{PoW`+ zhpZZ}FQ63m*G(OJK|vqlXl5;|W_+-x(meDNg&V=q z6!9I!DAq7fK|2!);;r$sPf@r!;^+5y!44IDk{x{H^Ryz2xMmMXcPfK zhICsIot`KVE=c~Ok>;gbwoG|ceHO%~%)L5YDg6q^BMU8hxirAM?oQU^P@xhMq;r2L z^l+HXgfxdlEu)`Z){eHvN()sy}O8cGX4(R-Tn*^+l-^SlvdYYm4aQ%9K*7=WBv=#opeZNz64vt?B zTX~D;4moXg4jHZV4mmA!;SxUx6oj_gzQ6b(CKK4fS`q^!*21JMET%(fXM* z{R>@dd-Hz;R9~Kxs>$B(fm){?q4i4NQR|$(g3`wQd;xWhKdzsiz&&zqR)EJs*q8g& z?wF4B@0d>L|ME~J`aN`&aOsqOxgO#EdHD$SmT7MYYL8Kmw5}GY-51^0o1=29L7h4R z9vj;Fy1fGKmf2MQ9h3AYm5UqnyR`$V=em1XPupnzNEJ+YIq^NatMLp~(Ce7_Jt(H{d z;0pgWYnv`bq@yFY!H^=--Wk(sNHy+Y$h!3-BQF(l(Y)iOM5IIhHIk&%&vf*Xn;f+Q z`S+<?UD*D{y4-^EHo2vMzyF5b(FeSyrjv@bg?)G3sYOZJda&fksw8YVtZH(}>Z&@h zZSh}N^yCs%Pj%#SYLzONCNeFZdevhC`|Nz@q7=Gyp=svMjiGF_%zYPbb*w5S-D4e_ z4%zG1^^(ZsWA9d%mO;v9+lC%Ajq-=vf^{&f5jAZcta?QaOE;Si>C10b3z$Z6+v4SR zUlj=ZcK+-xmE;Zk1e->2#Vnb>0CpXIxdY>7Y#O{sJKD8Wuy!i#f!m;EtaE zl-Q)mS5HaW9Fwd)U5*=YRiewn{DnhC;or7LCM~klI@%s6wX-*C>AE0Or|oeDOsk>NWf+EpG`|mAbX`k>aQd;3YQm^DZjZpgK~YUuq`Rd#N>^USV@ zRZ8b}AGEv*Z4E*Xw0v?ab6A9-|FpeQYmHgCsBPQc33P)mVtRL2q~+&Kt4Ah3zFMCF z^uVPTQ8I1s=KjVlms8eYQ1ZO2G+?o&;OY8U)D?=_eSP!w#4NSD{%!etSFgXn?5n*y z5)FjJjiTHqW_`K(mps4!2&1Q$G(TkR8WtF}S~SWa7^4oI2jhmHMzHD)f$aVJJ-iX# zupouhh82H6C>nY|SH~ADDm~6iw}{Nl^fxL%HM0L1 z5*CXdLW|9#)gf!WCyI((j;QgFLsKJqzD}bu`MpvculEAJ@q1JHeQNvbyd(xK^6P{C zR}D3GRXtjPr1hA=ZjY(s`fssma0$cKw?IYA^1vf3ZRig*B&n1l? z`=V9EpDq94%Zl~kHkyVWN&A$E6b<3VQy4dfIlZM^8YBMEW(=Qz2hp;RosW!{fB@mf zo=T;SPlK${?hH@nytk?DsjsyX`_5*Dt+z$J&e8+glOA>x)47~6i}CV3{piWY0u`3(K)F@ zCAcinR{4Yai20CfQI{@LTT3;p&LF~5jzgl4gqvZib&-7!^|Jv&^QTl^);it?`sj`` z`pXW%e_**MA1vdbC|jX-fwJa7&zfH7HN#qIc*|5tL2Q%yHM{IrX?&sxu@B8$|Fk^O zMrR+Pzi6dSCr*3%2VL>Dqnw%K?h(q6z2AdJ3Rc61Tj@cs+knWhtEw}v%!1?{$s!A z#r92{CDfQas0i*$77&;6^198jQ&ui4$P=@N1Asy9$z;%@DvUu`!~4#oXfTJS zvvPOOJ^N-n_sDRhfk}QIie|Fbu*E#9N&)b$;w}gX(G-yIj(DStx&Y_RizJLZ^*wL> zOA^|lR$G!x(M&>t!k!HzC78g9cex)a!*_KW9qd;K_dXy5FRcXa^b7%N@uh5wUj{?6 z=&pTMslaW}dwa6&DNE6-mLKfSzu?VP6t+vRY2}IqD+1J;Zn8i(i#NfGvdzp5*`&HA}y+lIWzZq`PJp2`pk?PPG*^&^(3^ z_Kj7H2`BEOfse=Ec#CM}vypAZ&y~yi%>U%dRJO1-1T!_GoJBhm9O_n^_hQIj-cjya zx$>gl;_jaF;0mg5dvZV7fQ(C96t}_*3k|Sm@uSt6$E4PX9|Q%ty7<<|UGCzW#4t`3-pw*j2kPk(3Sw4)u&OyZ1${X1JSQ4n{{}ywz z`q9fBty=eMtsYIh1V*yG#|<0T*tnYLJonHB!J{ul5T*JiA;GCPLyBNRhCihUxn^*I&3EeNKiN+C@(%h-xw8yd{mt z6i%?PcD^Ff`fawGc%!qS;j%E9HH~-#FDVhrQ*aWzsvC3*N0-xC8R7^MRo}F3!nv>* zU;7ewDk-W|H8nmDXnp*&2jqU!Yz%JiK6c?SH%Cn!Mrn=Y6T)Jp)njqOujxkE&Z;L4 zLGj5IGpCx&1nx3pAuMYW(MDoH&ea>4f=?#Y0P_;_QJ2g-Q2fga=8~Hf(a`e(Xa070 zVsOx&mFnUM@;dnms^~5K`>y4A7=w4FL)c64DP{-_HOz5;nUfLdizv6mQph^Hv6ByM zx}?VymgS^&;*Hkftdjs!W=uV#vuZ%xVuI(lRhb>H758h`Ewg0Ip|!D}F|me?>?JX5KV z;Nsd+YeHkBPC2QfndsJ4lBn`ZZOmY6;T(k)=>7F|GSK<4B69qER4zN-*^mn4)sI0} z_sic4XU_3l@57*(g9Fh2DC=WCIS6DN3aTA5q~U)G13GzV35_6hGY9@W3uy&#kAZgX ztcP6=!ee9u`V~<=#z4EetN(EtI}7&dpAM>eSxE?{`xZ_$B*+>3Vg9oskN$>Aog2X z@V)fx0Jh9VNKZ~-Ua5>+0FXImQcxUf+?IMs^KSqmQ zZYl2MgTHmC{#*P2IaOYJ@*n&s9j&3xSPMq4&vVY| z$2-rN9>GDPR9n?53!bev`y<W9mNFONi+TvlJTb{X3uMyn9&M3Ef`*MFty|v;5jX}p(YPVU>(s@J?Bc58g<~20Y z#sptN{?SOCOkVc42VC&>!Z4ScW|D(zR2YZ%*ev*PQvx=KCOr z(>z_HyV|2;kMJ%Y2Mx5z!ce^)(U*E;vY-7dM&{l&qan`5%_=M~l>yOP@Uq3XzY@!T;abV9D4l4tk>Jc=njCYt_MChW*NL$g6~NsbzV1Jl#uF>BJ@8H z{`_AEH~BvZSNjiyU;l4}-+vZMKwET(BOm99+20R8PD933%i7w1S`rY_WmoXB2h#`q zKM3~_7{U3U2%iW^LxxjphZM(zh<;0BfnEe(SI)x0=gaAfcCiGX9G`NPozcqtK5DV{ z4g?#hfw_1wbKa;@8wtE=*ZQiR;cIw3dhxA9&2QmG&lDY5WU~+$nPL}UpVqf~tCH_W z-?%7{_kGIgTkc&6e8@o_-AAjXj&3*OxF(Gy6wa}>@OdHE0%`J`d8ToqTeUTtGKstc z=`9nPd7112aprmd*K;SD~9no3h%-$t7J!ke>hRNV26A`Mk2@z!^?&lb3 zH4DhK0Zn8{Y$p1Ei64l6delT>pV$v#QFzbG3jZ@GlzYB}IE0K|K2;gLZg980BpZaZ`!O@j~ICepN49+7wy?`;q;h49`E%2yf5EK)LF+)T8OFL#+bKJ|BBqSSsX( zC3%WHf*FLlXLZogzMz(uZ@-MIWw!$GW>x(^4CkcDII5%>>(o<~tn^Cm%wuonn1B}U z@%u38YxlD<+kZV%{11jh_2tr!L{sz6-tNkn=dv+?NjC!**L^APW(vm`PlXw-)^k|_;VG|_Td~1WYgIME6x&+i0$fci2az#FMz)Vd4r(e`6dVd`pW}s zum`X84lE->h$(*Tz!4!G{zVtRpD*k_`fDN_S`X`}-h*h7zi)_&pKv*eSnMQ0-wVdY&ov%l=a4N`_^i)#bvZPiqH4?visAA7)V@O7Cip6iRd1e z4wgjeGl>AV$G?TqUzEfL^P8A5^4R*G<>uhvcmW>-7?Bf8>W`&gTzs8=ntt?R3f697 z@k=E_aZDa#h}It_lD#K_-kT|jFil4%`q?0xGND`6^unJ^@raBngXdN3AmKq2AFhH( zDhc@WE)QHahWk#Zi>{a%!Z_WeWe=qZjxum{!Vo?1`;SLO(|B4Y{Tdf`qHO<;E6H|$ z>=$qMyxZ0fa--+kO@~nRlX5-tSN{XX{@lB0d5PgPPgZ`TFm#e1=p6w!?p>ys`sd@y zWIYdZE(@gTZ4ub+ad_px;31#;P}xC z$|9Bqy7;PTxRvlfpAP3WSvNS39c2JCJlmS0Cs!t<8zhlOP5@H>yyhxog%;E60y|=w z@*m@H8%m+3qmBni=;gnV4PSZKBYB-w4(|3gnJZ*qKbBXdyPxK*|6qhxClZGo-ytP} z5>izd@`d8xrY4Asz!SMEE-^})lrgz&p1KQs>99tdN0Y&&h$d%idk*ft;cyeroZjGsJV3CofO=-9>4M*U7A{U_c43Rt|_ zBprZxP-x6Nqd`^%IRiy1TiRF44hDnS}5N+H%SIdaNiYKN4H-XJqADohE77O)V>m2?8=Fm*|l4mBD4^?rZs z?}8ETADn2_WPk@FUN{xzcmci1QEBOv?x+(6FynwiDHIMe*SWs~5C+gcqES7mYgANF z9mSlioJ|aG1y`Ysczi~{VqrrTl&M)T72}Vh?4pT~0(N^~9`vB)eWnOv`&Q?m>I`)l zXb@1VP*~8w($FBuz<)Q-n}?P7RK}d>4<13mwhuW>+w)cfTKwI?&ar^D1j%5M&E&TX z?5bd#s1vn{8D;YFaX~JkDF`qXTxP+L)l=JXOtOd&=amHoKF7SyJ~ID7ZGiFY!P8oq zL>bOw3PcJqrbUyh%N%t&3{OG7i|fn9b8Xd)PR*((Z_H~{&zpuMMrTGQC4K;eCyt@h za*&{EzT?nZ+J^m63MDg8aIW#abwKN_oUL-5b+e|D?UTff6-FSy;-L_40tv&E96}-K zAUv%ld$ENk?%AzhaGS#Ur%P?Y-PWY`lF#}KAN;(xWN6L9aoGy5)xVeKwgHGa@E0Da zy$qlyfxL?g+uOaS!5xCocy?Lq*Jg%(s;!<(obdicG4)!4k$44ynOblD61fxj0=~bzgkVss1)vWk$1TE3Q6yRx$E+ln2t(cw4hNKB4Qv2s zf2x%X5K?ZP1v3l5L5^T|<2nN<90DXBObkP!mFq@i*+)9ldpq7SfDNoMAuLFLZ3c!_Civ*=`f^CX%^tLUpjWEBBX04soo z6dTJ_HBfjY*@Tc){01_qLk-?dFr<&O$fsdEQmTPQAXSrRbT>`#Tp}!eB@z`*rmt}3 z-+qc+!WJ$yqGrBuC5Tbi!PXoOp8ANAnPz4OEa3#)8~_J+&`3~GM`egMY(Og=gy&G` z){;H{8KmQPFF80uKpXZk`0#`RCgK8U`94(YtfS6~>xfIdKX|YKu5MWL-36agplez@ z#WYu_iXi2L1*S4f|1usTLXAl0vY^GKY&ne2%iwSlUYr)rsc7md7We2F&;v8(h`331 zTGTidox*cErxohSp78L*iRtcu9sFM@B?sjZro~#Rpa+6MqrnD!!?G%&t_8k}2((j$ zBm0;3zzyUndOf1s?4v^B6tOP>`G`0$Tqd7FJZx^AEyM&4qJB}WvE z>aa0C7MNO_mtVj6t2thQ*coxq_sSBTNfSsAqrBmM3?JwS)&U0iIi_XGP+f+j8^WkCc-Si2OS9o%@G;TVD>_yC+&8&u(oSCyeXYK~*DhMH)f zS`fCj3|aQA=B+UDDS|* zm_k~j`t~L0Ju?}nn-;y1 zW83q?biTJpfEfF}XfXP>;h%-Gpd$&jI8cX`2w##6K^TME;E`zBspdsqa%=YhQaO#CRkrQ!Bszn=AH@gt&Qe{G>9Yq$S@&T0Rg;$oUQTA zk#%Kt#B-J-$T(|YRjEXmuzjKo-TY{X(mE3O6?fq%$g86KoHaTJ2-{mppW-`~*$bjc z6Q(-q;GwD~ICTs-vl2JHkr$~3gWM7u9y106vnr-RE*2b(9=c=3(OMW#2Lq}RzP>6J zlsitPnO&<|<( z=NJlcGItDJ+DL&)VY!SDLW+hgj}EffrtK@1$=(#+)BV!HG*EHl1faunfRuyU&5N3E z`_xwTzZtE5z!7j9g^@bh>h+v-6q%*v#oX{5Wm;5t<@wB_os+RtC3)+6!43{AWe6SV zndHn}pk9EA=#-td(b-T+${@jyt|=wt#LL=YFn}b<4DsqdVVKEVG$5ze01eS-OOzuK zLSa0#4gSy&ybG1j0$zDL2KZsO)U||Nqgc=jYHyG?k9d-UYv6kHMA)%*YBs^N_h$`2 zh$q5pB@$&)x)7jA*osFf>_BkvE&X3Vqq{g@1)V6(U+23uIQ~BRNf%QpF&cg~DpG>i zJuh5i)QyP9MD}EUv!F`oUU^q< zPUm|v^YhL6*-w25C#W?cr+D$w^uI9!;x@FaqxU_PRaT5{Y`oeyaxk{?DcbC^9xRvNkxmy+gwpD=#4WOn9aER_XWdJA z??o3Cj(7l&BnA1gnBG`|scZSj39A`Oy^W4ID7c zO-wYZLd}8^gO`Xxo=Ie9t6V!Yxg3N+5v#l=9BL>kDU9gOd++}3g-x-*nKBy^RQJ2R z7OZMaUQAH2+WS!a7{H5F z_0ALM#$rd1z&al{qIoW}iOLENVKG#MP}86o1`XCl)iGeNn)FpbKttYMZbx82s3hz5 z?~`r~NdwtH)&6`h`;C+}#*Hlv%42+CJ=VNtQBhxqT{4}8`)sja78_zrV6ehmVSZHj zKAU3i(cg%@I)7X;$80xncTiI`et^CIZJDW;SYzS^4E5e+BVH@ zosko%!uzy|WUA{2D>{i4E8NM_@kg)eL-ZAQadEc1u*Uwj65d>rUdh(gvZglTekM%P zwHtOs+OkLRgG!$c5kGI+y>0HvvlAdh%I4SZRn3|MJy()to`ws*#%g$vTB%`DH`b`Q z6Qp*+1}Va9MKGxNbKd!qzDvJ9J=;tgzJNur) zR8N5npA}M>_Uwfoc70|Pj5hlC3BX=)9&WgAW~gTF8f6+@I1(IXnr`4+Q_Z5R7MzMi zj%3MGV0l!)1f164YA*I$pZ-yi4TU~{ipCLXRq80pX=8`PC>z7jyuo$>ZrqXokNyhe z(PC*@Se8!q2m-(rKx6Uw1Ttqc1QhWlVzp-$%15mQVLDxHrEu9`8aU8w^Uh=}_#^1; zc#lv^M5ADvxxLp8b5E>T%R2L}vt4j7b7@vA6smI(k4xijQ-W*akJtoW1g%g#h7oFk zV80%LE*F!`;FWE=Ju22b%QSlEC6$*C708oPuf%0rBB7K@@Dy6Y=>BRMgEk)O8KTD$ z=@7qDe?iFFoaMY{&V3bGIqv9oJ)=MMKM`SXb>ZI0FI@&3)NdACy;yCL)e3cL?z(}J zAtAtuXzu&119w`fKaalASbD}c305*6(&esgidha{r*$s6TLog3!AMJBMBV!K_>CZO zP+<5~v!~*nGSbtmUiQ0$aQJ7NpfukYuBFEI-G%8ng=|}X;=ut#n@nvneSPQ#R2|rh zP{C1wEgg@V2uMa^D_o6M8IR|xK6)2hEpX55(HKTC42-hp0bijU1OFVeUvT`Mu2mZ5 zp#UAhR=(Vx0JXJi5EAAh+|lTWMIM*>gG#izu?_y#-Di4xPsU7BChZIQ190l2EO%!q3i;F ze9s0CDcQ=x;kP_TM7R)0^pS8?an=$!?;rxT zhrLp3omZHq?X5V}UE=Yvy+k^gXUWVpPgSa>ERbYy-dIuHZNzz1QIx}h*m(i9G?n>yK&3U$0WNoj|aAn{=w_9NFN}sV=lS^iW zS0SHwXwoc!ZZTUbHEb#6IE2x7Z5bNWp3r2;)l_Oy!MU}In`d#O7IEV!8VCqLrtw}N z((}<0jSVrWz!Kx&^0mXlDGSJuQQ(paRp-7qU*B1op2j8e*9}yjE)3Nz+`fD$Uj)9g zDw3uk8L-%bb$5hM>ZGS3*IQ~C{IK#Bd>V5ox4@O#{@eK=!@29mqiI%6dR3XT?J7v{ zM4QVbndPKuLf@YGfY9zydqmvpDnVnvyr&pcfw^&leb8vC3mIQR+={1qJH!TSGL8nm!w_& z)OvW|J!AiVEL*J<29FbXiX3<5c10F^XS+x!b)9L%@P*cVM-01V7~1bH#v<~jzg+%Q zRKr`S%mcBdNms3l+MV-)hl4Bq4&{Fe&gDn;0n)>dIHAFepUx6~#7i~DS6;ufF1Ni0 zwEpNA&c1SGA7{i!bj`-$zFobF!Is?6@KOB zYH=M;C*CMcToH=)8GveV zgy>kr{UlZAD(g!@#%TqjZ#+bE=PSw>cf~1W29t@4`!3S6c5|%Y^{b1*e{|n&94z!; zKB#>1*OmXmbG!(CH^Z3v3gkcHQ0TcB?S3`S-#JDuFT0>`q>PWgXameh1Gp=2`V8CR zOX==sWy1KeyOsyGeJdQHTH^| z9Q-l9ftwn;<^O`BVtzFn+37=Zz8OJe|2ycf@MeGOIT~h#)(ebny z^fTl}8l&HbV4!oM1L$pQk_I2(k9{KyVc!%<6 zE-R|^*SOwTS-)ZhtzUg#-JP%JZcAU%?=98;N2amn--{gs!;}{c|iriCdGfnfTJ6Mc0f!T#6*Hdx<=mi3C7r)Y!e#Z!Ffq{muItz zEd;aJTi)p|7@4?MBAo^L;mZjb<)imvDG`Y=CE34nmlF@Hrf&}XaYIL*%P#t@MBg@B z0DeC@b$?@Y`L_A1ffg(GG*v#JTMM7Ff@gmX|4qfyM8PwplRtUO*7uOz(l^BX&+u!c zzC4`+;C>c6ZXw0g>62LRgW_jpJSq-Def;^CiIETRCC7@r$=eY+0yaatZ^4d@8+W$8 zR@l$IbU+#A9X6WP2C?zqcZrqv2zB4Xq4%-;cL;^D=o~tH7~RtEPqRu{+S9w+Lb8Nz zd#?1Z%nmbx^{@%MS`L(7AKZILNjN3y6;J@~s{b&{A9=Q{c}I z;m+$Hr}+vk>ZG{mksrr(O5;*4l1bsf;}l6uSN>`?N5mTAU++Viej5IgyLlY%f#-qE z#cQh6w4E9|LfcqkH z_R_+M$~~8~?43(4iruoywvXEmoTgJjTc~JA-ASrOrPb_N0o^wFO!h`m7{PF@fLNNq zD_qS*j8%F^9W?>@-_-8@9WUYgz$}03!K+U8$g@Mf5MAMU((ZUGH~|w;@htj&?p*bp zIb)6AQ@s0rM@2ak=L!PJutyhv4CFlm2NBQ(A{F12zr(IIwV^Evn-@( zRsGSm&hUslwi$4fe-k!Bm)k2a!c%-3yRX{DE6Bx+wh}D&f?}-JJ2tsuU}RRz&`i*q z!-{c)9^B&;_nBP^dT{q=H;1hBI1Cso*oQ6=**3Pb@T(J+^dHrDmy?D{E;(*=wyUF8X@!D{RB0fc~MuYd}5 zN8N5PhJ=(#fqo|?NJ+F2B^W4YQsfdS8|aRn+&-vbm;NPu5L3?BuJ)y-EV`P9!)F11yGO#$v^y@cH~t#p<`4OZWh-3;R;W*6BRYL z$^ahYKL|`k?ZTL(_#b}|h1u=|6q!^$J0&xP1^2cx2-WXwwRY}GIP$fHXq7NLB2G4@5>))bH z`?Vc&wEi1cfe5`T+8c;6I5r9fvY47NqDC32*V&P&yK~ za5eFM^axq;$kwpq!XeLMR2>Ylg*EnVz%)#p$ARhVWxC#xheOk&B0%kCvUC;(lgHIXMtY8cPEk zs=I4rFin0LFLwB&?u4i$%to|U#?~9Hl|lJewYgCnJQ3R*R2o~5?lski#9o%BaETm} z9W98i9?%g7pns5mwFO>CMZMy1Vf%$%X+~T?etpf(`sAa#un6~w z>co6S2yL((^Fl9pt&H*xkBt;x3~9?%z)xrR&>ct&x!iz6=Bt8Ue0|{#$;w0SYTAwr zmFHv8qwLnlCFF)Yk(ttmG!baPr3ASjfRX~tFQ9@kT#?Q%lT;AXJqJc8q4yd*x+B@k6lP*$If@P!qgo-Xq(2Ku2EPb4lEuh8m8`SmaGr^Y!Iy?lk z;FO#~5cCQ%>Th>Y-0Y&%0cdzBxI7(7zbgk?yAvb7YeXlh(jj5X$5D&ji=~6((-E)N z%TH$FT1z4t0<~?3rl#f4ImHJ#)>=}L$H00#sUCKV6)WpJX^j;Yv=%KiJsFG$$fXQA zZ(xt8Eo2c})7VTVBi|Xz1JwtF%$Ft|(cQ10iz6IJ=@J>cl17-9(jyZqz!DS= zu>&d4sN*7~VG1mI=5^;=L5B+6x7XXl23X#H5*;{}9s{eZqkq;T9GTU}-_6{pKMpzp zhLwO>5086!<@{HWVGLIb%_ zh6|S=(CDI5xFhQA0>q*t@qurX4mi#X2WCEmqs3+XHX`09p{O7^kK-U9a;fq=ID7-h zaEca@+7=;kn;w(vhJ2K{;}ZSe4C3|>Z6>io|GrV9nzofxdUhrCC6A0u9DdAauoeSQWqx{{YzXc z*-)l{{%`nQnwUj&^4Ci=+?aoXun;M}(l#@_q|9yU$NTQn3>~AAiYLbjZyc}R1Xy7* zYH^PrFrm!cXW&EyQ)@_d1#~;;w*#VxS5zshs)%yv$aUf2;7U4-lAJu2tVpOORi68c zx~aim&aS)-{l-M(B%%ALD?cod&%e>nFq)=DRzp_!`k6sv95Qt6UR54W{`X>1}wtApa zmhVp;DL03zy(bZlLGy6(i@4l!igQ<-6%hJKtpzx91R1Xr&^HO}Y(O3}-U{ z?QqiCF_Ftq{Sl4X5MP;Q!VZ8dXZ+s+@7I;z0?}bjJjxL z6sL7IVQ#Ia_@^jJ?dNfV(v!S&_?vcB!G=Z z6*t~YgBbW*U;wVftrdMx(yeg0{!f~QLBTv6 zP;pi|%MABu7EUqaUG>H zto(w#pOHCAa)Q8dzoytZL!7@ZYGL8CchwP=f2Vy&_P^8y?5Tm!26-dfw9ZwV;^^eo z8gJN{0b_%*c}lTo!Fv1xUaF2J92x?NGq2M$2eI8sduE`{M{TrZjei;p(vch`5uacv ztt}cUC(-eIC>CY~b&sZ941VC6VD~`&#`q!7_ky!-HoiomaS-$Q_{Hgt!N+XWrJ(T7 z1NB9g+-o_cfQslnv`6v54g?3mP(Oq0-!~^0unl-Sdtp52Vb4%^pu^LImNh)^t+v*D zn+Y#;DF8M(AVor#IP|1&bq_cscSi_Bu9S2e^UM_9+$6rz- z=15Kz7~^L%e0ka5rC(C5(`B}zhw&HmJXQFtv3{YG*~O4u+) zD2wYnWNJwoYYAQ-Nv}x&xJM!TlJ;WIo$pEJZF1h?&D@aaCp4X zJt|7gKB9J{a}Bc3BvzPDUJR95m&}hky4zgvI2vj0hcr9;d9sFh7>L8Wz+zG6>E&B3 zqjDk7*Dy=l@XLe!FIIPO-d7HgA$@bl>=`Ig$-v~^s|-RWqGJC>K7qlgEj==8PL?^5 zVifYU$swOy+Bz8OTI?B{Uj(S->VD{87w3UXqeeD4c7;?`Bj zVDSFK0pckyV8cxuO}X-p80~6tAuK3!xgGQLslal^r#?y10v{ z9VOj$T=K;2c&3ifjKtym)Lr0Bl^h)=)MZU-_9YVze6G0gjy^Q6e98&&`ParcK zRZO3g7(Prf;mV1%@K3@D>i+_DK#ISAlYUp1-Pbq6QD=u40J)b^Qb{|#=!faM#eDO8FP)fF^-xyt;zia%02)8GRh|@OLn=*aO7)uR9csjS zUd=F#67;-&n%;5L7pr1jRSa}Z)m3)I23CZ998?P@YOz{tprGhT_>8_QIw7Wv-LjT} zg)!T?lU8g}zMsFFZ`e|ehL-XP`Q{|0cMNb0TLQoYBnoY`LGk4Yk}b@@w~r4d@BsFC zQMd?H6=-H*gBQgPpdK_{O-fW^f+cY2R5VvyORm|KfAGSwY}w7pc0$nxsRANB7Nq&= zaPlzOh_|W?#cj3#l4Axd9=(&BB*FzjQE}eVYEAg935X*>MnGJ<6=;=kP%)&KeSU&X z3*?~dmTz)-jDcvQf>WF)kFjJoGnraKQw9X;)XqF%QIe7jh)t=csS(UAfqNHyRZN0Q zv3{@fR$>Hda;tia4qqPtlrkS!+oXk+(E%{+ZtHQq=Q~5MK=Wg6zMQ2nEvR)0LJBNLtbEy z^S7%h<~VA#`=y}Lt*+(tD>^9l?pn(ALZ zHZ6G{vg02JIARoy+m@6ObN@RCYpQT`(ifw#XjVbtN-cjB1giY_dLU|t&3Rhkpn8Bh z6Bjy6@^b-6{WDcpGDN|cGH>;s{mnp9Ocy^`PI%b^Rboo+*>yckF;mx z^7-!ldV`je&g^kB74ySp>g>NR3@=n`h7CQr;ow#GR+OI(X)l$Z?z0B&?1RF|CCGKA z-C8xQ2KGv~9-rP%soC*a=kMMlshoeHZ3}YF z{|nQ?EX$ualF&J$!t^~v?O2+CzB)HOua~D3lBJ}*-P3d22Rt|KcIt7jH9G4iACIE5 z^GWh?CwkQ#c^V;xUuWhTVTc?&1HoI;#Aff7EA(SuF7DNZ8Uhc(^M1N=Qun9`^BqZ@ zOY&QdgROQHp+?fRekAKB>+}@2Z5_)3L~brrC6t*XWF58)P#wF9RiRPjD0x#6R#^}c z(Tqu^VTLBG(gZ`m~DB${b^(qoljSWI*>znQ2>Pv5>1yCo(WgJkV1Q zDiQ-2;4zn1IZ~xfBEzI-;-v^HVXafHRSz+4-@#F5Uw#GB&?yJa5*7$U`pVSctWxX=bSg^hh{syBH*NIf~GU(Yadv=uCysZJmsVrxScN0lgUt_phQJ z?1AfXG&rNu%|jq1FPn#lhkH6`D(fQ{r#?`Rb8|Hv$(EMKtq$U2rpBxZ{ z(gzZXR8@gA2SlN?0%=CCUWiiFldS{xK@_V>kWy6z(p(TdxduV?`s{p+4n$Qkem$Oa z`+fl9;I?>(a=vE<@0yf~xgNU7lez_DNl(VfDcMq%Ib=nNiYO zvtdwgW{lHXx-H|hRuI~3WVC55hMo3 zJP7MMu5J@n_vL|E;_>%b;{$B)JFoFUX31Y`oLJ*_r;RlACHf+cyQ2s+O_mb|!|}^k z-E*CpGvunKV5Ix(3H(+*QUe&0`3!LjMpZ}R5qhs zn=)hBT1LAziKenyaIk1Kls!E?YK7IK)?xkhqXOIt+f&+F^xDBeBffLJr9&4+B+q2T-+k0M*G3pz3@_P(AI2RWVq_KD%I9{F4dF)1$0z zvq5`$wELJ1Ryt_eJ*@@7X%L>&8izsi^e89jN3GYXd@`&;>)*yGGdLwOzGi+_Nv*|7 z*VB1r?VwrT#?ZDf%M5Obt=GSeU1sph8qF;?!(_;O700Be&bou{sMQnQb}zabcg6T6 z2#m7oU^sz|D5428@*0zTwXUv4!>dt*$9j{Yhz9N6b*D>>ouaAe26u0}HR_16Yytxg zL~Uc#PGTF(LEwFq%aW+=`E(~JKw;Ymo_HQy%rjoE1E_wvj7q_V->xE67kb3#c))MU^ zkMx(Vd&+iF$`T2Bfdn3j4-z5dkzDpGp@Sz!|Ar#{YzW2JVFrW}>@WjD33iwPp#(e3 zfKY-R=7$iTN9UAaVIGaa+)sQLK(rh02)#+0Uvw6hVSj`jPX#LWwhGEGTW%Gjb zRm+txI{#K@2J&&CdwVtNj>p{&<{wfApshhioOf?q&_o14SI&FbDm)g9uRs=o?h%0m za*0H8d>wJH6&%9#Ai6cSCS6~3A=?7LKRy4yf78+{@nG5ugwlgkil_0)eUy@^z!$Xza2(f}glMP#XD) z-GPG1j=Mw2C{Rs_ExC3_w|6^^1X>H#PH2tC*L~b1=(DkRh{>mT8=bbUdlT1_!zb*< z!ESi=ZOO35+Z>QLJR54Ji8)^28_t{2rx*U($dWl)-x3&}4K;TZh|XIhkcaSsZ61Is zb9YIKv*`bo1DZ9dRF>q|M%s~!3(9zJwOTC?9Fx_&$02bbfp09T=prLv* z=iq$+htV3-bqSBKNEs(>J0IZ5qw^nc;sY>*fhMAp^HH}e@TyJB^G&8p#EjwMbTX)K z!%p>$=1j|cqF82Cec8JC)i-K{txzQqIA5A6h9-ll>Raka!e%4Io@DSJ5EZBr3(O>^hbm94Mv^mDShuBUWc!s|R&u`_AmyyIfGYnQPd-Rj3-CgKz~g zo?x68xOhRK)~vq7tDwx|OPcI<@iN2^G^gmS-x7_N2QNXb!N=onPpMPlu<`N`^d!*k zta?}75$t%7hx?$F6;M4J;S7r6;AJhWensNxi7mw)Ey#FKYE|gY>Hx zK_J}$-|XZJh--DF(^Q~l(M5FvG+s1|w?;ry`(3o2gY?@05e~I)hx*E@Kz|RbhoCM- zm2Ra(igtvL#7RWnvwhto6gx;+E@63>i_~Kq?R75v%Roig8C?iJ$ho7?SHwC6@wuvZ z^7-;vcXa;ok{52(9$nb^$AjXkb5#ziqHx*53pefVcsv~CQPKZ}+L;t z7Uuy4=wC4MT@;{yA#KUkyO*Rv^?J_1`$*fr0_!LeszYN+2WsvH^k`S08`l3lfWDj7 z`LCe*Z9uPnPoPTy0RCwPTY*jh5A>ah@%7aed^NV*T3AM|AT6xp4BPIoJ!$odd6+wV z4r_-%V|G4$2!r}T{jk=oAM9*jZ3bbj3El2~`p^uk2aV>@(axt2LA7~MZ8qvhFwb&W zZPpGC!YZ)BJoeS0h0v}cB99Rzu(5eq+X&@a$Ia zip!EIRZ=#17^cs~yXx6CSbHM{DQXJz7<~ja>U#LZhR$hYvQH-cu)4*Ly10er8ad#N4NH?Pu<_eWI#zuQ_%z z!?b(kx=-bT==C6a)oNox8-1_pbYd=J=j631vTx24L`VAF^#n0Es5Wx-?q_>Yy_s+D zUVesL+>(Lo<_Ixl@Ndh~B_o1RKOEwbgI5I{Rvdnv!7tcE6gH5f-H5^qj*JKE{eoL~ zq0GP-iuFZ=xgW*wRGbX22c7W?iY^$MaI-Sb+_BuEQ7k-QI}so-vI7Ka_Z<})Fv<=M z7^Q~>oXcE^-#sRv8e@SwFGqiy7=Y1VHwNHtApj|aX=Vt(pqUy2@bb@!0T{g;is!|A zqXOOiZ#kjJjtxkmV`Ly4naTp|RAObrL|LAvw{R^{_zBkMy|-*VQFgXk!F)epXqtC3 zRflTbELZo5Su|7wR^&MhLytju)SgsnQ+)$yChOn52TZ&pM9gS~Va)IJsHPliP*zEe zEjX631vyAwD_0^ zDq+shjiyE|Z}7$r1?Ws4ZSF9Wy9b*5uMRaCS)nGQU!f*<3N=|63ClAwqkVJQ3+?C6a`Jzy+E1fhN(5(X*w#=7KtB#lwDB}sPd)7FeQSq49G6ZEw*gf(1 ze}2$QrT+c)bx|grfQ`^bddSB70ULj7Zwc9`lY}e&RstG#b?s#2je>;axUxByGk$VvAD}$ogw!Q)f&Y^eA zfd%Js5PIPg*l-R)|9BiYH)`H82F~RGh?uvG1!p|P5KbJ<$TF!o(Jmt?ZAhH^%2=0v z3tlSHCd(v|Hd&^Yqn#wuCd(v|Hd!W#w8=6_q)nDdB5krv5@{1zsvUhNRP)X~hH8ymsFowd zrWf zaln1xM;r&-Dcrh|qpxPNuN@F@OPteRX!r{aEi}Xs2Ms@6HsFRbhxweVb_&J%cRPe*@gtD~@RTx* z9DOyDedR*N?AWk>A_g{ltio@{Krbb5F);9#*%<><2rpq^HBJnZ_bGoE4vO+oin?Ke zJg6S{iRNxNnBJG8k~EL<;b2B++CNRQQ!ar~eMye8%lQjEe*pcA8-RY{Xf7P3`YGuawz2ZSj~;G#<2qhN3ELM?e3VUG(#dG4831e;c}|GXCx3qF=Dp2$|YfGuhX6 z^vj=@;)e>8znsA0W&SBPpsd^GBDUB4f7tNG=?AH`sECfE6q*jM+j8HCt5HFLduKsl1 z?04t-rS{V2=c>K_edhA!ARn&%`I*0dC}RJY`D&ZgX4?__AMUuI(xm;RY&n0UTT_2o z{pNd_4)f?Y`BBZAI_^*B*}w2DUgp0+pH559_ot)V--wg`Lbu%LmLmn?55>Iibp)J8 z5%%}>UCq=PX$8L;`SO^lzn3n&{SthNTl!b&!Z}hw{zATg4DvPo#mQFD8i#9vCvUz{HPJ(ZM1`p92+_6yHsSKl4a zsLT#2I)CBfpNEUNqAU3Eqn5;vM48>ger&@5R5z5znM+ESi*$_q21}ztUqJPli{C)VZDWAXM+K zPh_q%dMXP2VW(RXy{qWe5Qf(aN}^v9*Ci2M!{h6#l4!&Cb{GG7RpLf4zwe;^%AaYM z`ob5`(>Urxta2iTW>hicTtBScJ>L@Me&f?-oArJl5c=?ub&j0pJl(d-O4&uk8JH_L8Bg3 zE-L5K1^g_Di`fRVx;;HVQVO@;^zCvr-7GN+UT}0!6Bo}55rncG0KxR>X*R`drQ*eS z`AB&Jd$Z|!BgX&tdAgddv9Y(0vk&VRCHRV|qV8s8&io7Q885>&=J#4Xb2>v9)Jx20 z`1JHRznjvd<%5`tHD#8RHO`mM>)HF|<2`0W#N>RO#|#seRj9!4i1e`D*L#I)Oq%)f z#E^Kv8~l3=*a{tmJeT$C5mUxZAKxuk^UeDY&cjGW{xIj9 zp68(gX&V5PTu_)Z47P1A>r}v`R`bu|)BE||dxfp;7*?}))73p^w4SOoqYT3}w#-!# zuolqVCSsdnPW3P)Dbj)&=Ce~v+>Rlg+m7s9HwS}~1JSux+e8A!Td~ic1S|^lYnphK z-Gsl|fU6C3Hd(iroUt|Z3hrjCMf9WU&UCR<2~sgLsiGqHl=Dw@%RH^y6|LTQC>*|3 zvYA#Q6KSV)d-WQMbdbMx#y732TvCrC$VsEaA&_0mrsigvy0IMG9F8JLwHU+PmtG`hYKJaH>=)-P;J% zFBE9&)vaQ(1wo`}z}tYmSE?Q3J0x2)g;1ETg76HxO7e9QsMU9R9>`|_3)y`wW5bYi zL+u`B89x~pt_wkls~3xIKO}Qhy1!RY_v0q&?p9_gjrGpab$ddrI>wHbC}&fE4hsC@ z0!Ba*u=7rht>3yWsPSDCi={TF>co_`T*#IG&9I?1&AW<_R09vI2BQ3N;mRKePGM$G zgi5Gs47xAdJ?GW956^A5?or|5-d-4oLM;Od)C~NyFC+}yW@=l82bJ5sz47m(NnzYC zCZJ>u&jA-zEXQU9jQ&{IHOeAh!g_h^ykwX*2&DC@GhmHM5|3I}SH0IB9D)(=8<|*O zd+mx*5uAB>SHIz|eq!mJb#M3v>D`Ei!FjjX2?FhE&jO8^G0dWW4TRyOD+a>>sA|z9 zdes%@-BGtfjbr6%r6jf9N_?6ptWZ0%Z0<74raMb#(1_C~<`Gj_+>)^FKvnid7$X#1 zfIt!I;T%?--jUoAszW1z^9G1M={11pR0!S|_kcsh3gHN#Xzb~guF53PTlrdcPD=q_ zi%HzYr?g&)ouX*#fM_cgBSQem7Kj3+b^(S3%7*-UMPG~Yt$x5;J+S$d{?J}W{v%;o z(qkeWM)%MyrcjB!llTiBBuYc7O<;Aoo8>jRq}7giya$;C#{nXK$;L$+u*hM!s%H~f zV{xhHj*B3hu2Iv6Daell3kjjhBr4&v1?Lx@w!mPEY9^oGi zXy;{3zl6>bZ|nHB=EaG2AqtCoF?{Cn992b>#&v|vc%Y41kqB6nzz{vS8iNVnA63mu zFLVX3JTy+L?vSq_sHP7liQm`-PEk!2Mghf=^A%Fu$euH|R+p{SRcmQ87Yg=uJ$dZG zY0k_)2>fsfd?H3riz6rOhd4B)EtG%QmPb&Ne5OZuED9}{dZ$H#^Pq%MalZrq4B-Ds z3q;^c;JKH;a0bA3OXA$JKAwSqewAi_#2#IXQaF5iKY10|abZ_yRmCofn|U8U7OiaWw|;$$J3V`uXi@ z`Mj9}T-UhLXgGOfiGG-&O;$F< z3u~?Enhi<1Z^93>PtMnD7MU(Uih27*3}myiA=nlA&57#qq(oLOcrkqoQ+?jdKv902 zt)`1R=mGTi53|i|g_}pV^6C9@Jp*he(+V2q)_1G_q(Oa$b9-Eq_2$zGH^KrfVF-E& z18Q705nCx^%};zR@qMn63zrv+|_yqD|^!tVf}u(5p#fzsz%Gx z7XT8pF@BM?O89O8jVnWvv8+9p`_4?sU*6M-QJt{=N`HE;zkU#f< z748Q>Co*bAB;GY*`?O8*6HfjeEdGWE zifsY@teA=+4nfbbDd&%0G~!_AQ`nLU8y0|IC1~dEJ?!R^#FNi7dL)4aPeQi!GXX`T zvV_9g-ie=Z4`LIm8S-FY?ax5}R%peBJ-C$nvwH=6uYeunBddfuQdX~ky#Qhg+Iuuj zG;QKUaVZcGK%%BkKw@CL)6EPxxLRP@5cIUCJ8H%7h9LFfd5x?B(4DNMIA1cmuI1Su zE|J_mclh!V2x>)%4`0V3D@;!m-65$$o)uXrG!-k{*A5Am10haFqg1H(G`*X-lS8t% znrR}g7!WfCmhq<6ev1ZI*ON+xNC=56D6NQ(Fn`3AHI{V+7+tef*h7ma0s^+C>Yh#4 z{0@daN8yYPcdTPH=Afw?UgBpLgiu8*Y#h$VeA$_!k=lE%C8pTyw@3NMzhxz;EQGo~;~0IvMO zJd2u0Z2%VFeohr}z%YP5lO!e=GZJ8Cs}-GVD*JVTmKU*GHiE}BWO8C`jFDfM4Kl6N z6Gi+iSDW`sCbsu8q)E#)j|v4hYURW951`P?)D~7V67EnVkmQ_E4o6#&LqywNHMIq| z4zFecQ#GQdHe-o^+c7n@l@l}OZYA`NjgGyZ-#(@f1y%xu$R{L|C@f?merhYQ)P%{c zTjsT9y@SNKGPVp1cg85sqehe`4~H-III;Cb<`MxP!EJgsUC;Q?diwZGR1wCBxI10F zor9#b$`}dY6mSuF`YhQ7Iz%i#P;>KpB`2gd!JSGbNj-xwQpu23knEVfwp7>{R9b^h z1tE+ESq0*(?VhMZ3(Up6w4I&L6`|IA%kuaR$ zKfu=Z@SwfLoD-(|X}S6X(TzA0c1E2N-!ToaP&kR=R)2yed}X;5V&-$ zBK-|i^QleXc+nq$PIrlntUw@{uS}x|c9*oeEesb>W%ImR#J8H1YzLs?DaxxG=me*Hc0{jn_thAzzGw1!Xx;P zGsAyUyS3dnc($`LDRRI{H)TtuOl=`c)uasz%P)16Oah&%>nIE~pip$ee28M8Tx*2)nA*`lINLFBTS^+WK|6ut)mAU~7S?x;Ix zchTO5<~!lIEsBeZHr{!?4?V+B{)h>8#AtC>VW-3r`lmc0KM3lT6u%hqZ)Jzg5(W?J zkI(*G&zPWEZK50H8aNqLkv0!3|0KO%ycP6#X+-2Ur~G1SmGJv`(F6@XU!u|6vZL^w zoF_c7UjZ1g`sDmVRfl0h_0jC&OD<dk86%O2gv7}gZ~e&CMDhs_$MHToQo6qA02bxKYS#OEdJmpGw2b|PsGb=rBhXQjU28(wPqey zAhTkE56QSUJSW5cimLZx39drjI+&ullg9vh59!Ap|6>L)Kd%Ozs_k5GiI2@sT3X9Y z=MItIx-Jm4hO3|D@s+A2RJuI1Lf?5I`6F~%>a9E zI)P>qAPO(|#OOsyyr8vwp<*@eCo8^Cih2q6>EgUQFQpKz)?#JiR#2>jb z&8p);C1;@>T~eSqIN=qRZe>ctk*?vL6U)WQ+qr~s_|sub8kyF4QA<-A+n)jUa0jr< z18eCsK)cKjpB&rdAZ1wuukHn(#0R#AU#cvGpX)1PynJrifqC?<`vcMI4$da$=$GFS zr$F6_8DzCnsiY1IK3E$jf00#&-RJNO0r=A(tE51Qy@zM}^rsB0;G!IqdI^ubdNj5za7ME^@TZx%WU1rj z7G#T#e^#=Q6bwvRM;hFDYYfz-3u1P6f`nzz?WCd)09v98g%fU{w+3e*r^4I^-EODb zN$DsJTR;T8z_lP$^OwLYg;a`&*M-^xN9p*`L5D~s4teBDDMLCiYj8%sotlyM&!<9_hpeQ|;m>O``!pq}D{*vPR0(y)7iWQVR4KnJv8 znm!N4q^GdG5aX+EI|6W1xHP?KT(wg|bqISulEA)9Ay?2HT*LfMIc07_gW*F&0!ZN5lTTi9j<)ez(TDjE%_G&5mf;lzfO+}awATCV{DrJ^ITUP@^Sw^gl~`{qdRs-uof?3*L_ z*u6P|#34k(^%mkgJQ81jo~L1bR6pk$Ae&h5K1Rh@}LsyN4!8FmN0_ZdPBan zQ+E4QW>lSy=nft)<&)Ko$7Al?kgoeSGA@ei%7)`))P;fEXDSM9llxxl&?%3TH5k z*T&Ond3X2xgfUXcC7j($`qcT|@=-mYCEX9m{f7KeVjl9!7pQPUPOR*GGDE*Namz~_ z9|jEMP0?w@INsq^f8`jYg4|3u&z5&Mxl6OFIfp!YKz{@7mb^5U9&af6VB^O@Y}lWs z=mCBQ3$=cDMz4zHTXc@0n^=j;AyF0$1%;@}6lM*R37AVIZWg<{uF_fzF!APHj*_X3Mq_}mM0Bsa^!V9ag> zKv<$%@+|0Ct^&k4@ZTGD8DJh`3v`34Kr=AMfj}MVyK8ycYIB$myA4BJweLV%bFUj7 z;4S_8nx9$v5qSi#g8@Ykfez#w@(iFi7{KEtol2A_ipNVThK~aB7ue0nzNP+wvl#m2F{`c!v4?~3YTcA+iVx#A{kbJ6z zE9nZ;9X$U`JtP>nQE5g5E7*ESLOP`z&TW>PaX?0N_QhXs-zX!y`Lldv3vIE%{HwIX>WnpCCv*k z(CB7AiPF}9;U6N=I}Pk?*MSAL(IfY$;xy73RsRYQZa`s9<<@_lXH=?ldFY9|FLMxt zb%#057p#VTMoEVyX$VxafMG!*qcea)dPNTe*-qQNK0ZY)`J&sV)6s&9c*X1EYDrw9 zQd6x6pS?#?A7tq6j=}vx342MyFQBSd<^_s3ahj-GCA9%$56|wpbymbbUC;i4{Wlm+ zMEe{~1j-cz`Z8EDW*bE`20^fOh672oLGm=|O7X78EP*7?bjF3y`-1U+8@w4K{*_?c z!k;qy>BHQmRRUM|R(f@2+67tWjK&(1iax?-4i5Fs(N-A12=tKvFo9mtI>GIA0z@t` zSw-bVS;qOX_?H^5pIcz1eUv2k@ZfgbmKHgDOb&S?X0JWPP(1U^46u?ZfN-=J6}%?J z)~~tGo;9_L#Kd;7s@g!86zccm*X6StjHmgkJK}K90O$yv7Xbe}Z76%WcUCGOOu9FS zqHq?mQ;X-4WGNqK1b}fqsR!*DMsq3sTV9ge+z(|hM_GsLTh7vn_lI%bf0&o||Nf1f zKgbZp#dl-f$=6@Q{2E=Nx;DtYa_h$O~yli6}_Q*_W{|Cqt%DL?^x~y56kF z9-b0vAkLIyY<4caE8+LY66RiO){lQ#g4tNR4p)N+Kwi zIx*y_Iyb-*@_rYkmQ#Q$?gPH^%wg$gG7=z%b(zoZJzP*lEKAmQV-e{#yuQ5rkvHDm zZMz1L&3qkOr=b)yWkFY!d;9Vb(AvBvvQKOAg^%tKcqCpSiJ~tA$||wT9&yb9Ew3Ht z&^rH9#DvZd5hExOf_kbbRbtGAo5^0ch!DeXr^&n11sr5ieZ!DX1qU3-8asd?5h+aV zh`aYom;&R;``Ps47x8IEhu{T_eKA{1AA$Vo&>2N>Gl@YX7Ey^A!S@NNbfZEl0Y|Z- zDc$HGMEC4E;E(qr8v#}XoM=$$;g6KqM>-rDbOjsglp-h0z4z?z=j*%YH612C&NkwC z&Ec?+(e_a&lRI*TfrV~-4aA})-B65~N<2~uzQBukz826`ArS(_`6OWF#GBFt%OW}% zx10*VoIL2NU$+oh{q-V6&6_x;qCGzL+ z=Xqh%c7tztghy?lc$pq1YBl>XMcWXL!w}7s&Ey!`?Kh>3O0D6De=LHguXd5rqa^Vz`?}UuBDiJj|w> zXC~MiKO)Gn2gT!n2#fW*QcXdgAu`%ebKtmU=5xur|3Gd%hm9m%8E~02+jTzgfGa*x z7z+w(Dx-uvEFT}2pRg8s1Ni#~q5RVK9K=Db)HyBFqeg;JTey!rC zY3CLgSZW)(5KZH0Nn){dWwA-G^Wnrp68?+X=M687UKzwWf1DS+{E|vy7|JJ=H|P_R zS}l_K_oDc)T&ev)1Ld$36myH>DEg{Vpe>x>F}pZv=&X6sFb|ww@?>=t0Y%4WyJtcm zBch1M=@$^!Qjpd~__ajWwU62ZAv2o^hYK4FHwaFX!=7ot8=xntc|~^`7LQ?m(8?dP zFKSUGDPgc>Rjw6}2`H~xJy6>Uw6KgV50a;5HNtI$O zjMVLZK)?*Y4w&3TXoJ)@&mRUgBG#$9CxvRi;w_?x14Sw2y|Ccmh96mXBIf2NQ!SUk z5SQeQSj7+R35>sNvB+d2#30|#9-la=8b*iaIJ5Hwhq}XPcxptx20nTw!f_oz(w|}= zKfr^T$KO+6%)c*7Nir0Ve4JBsQ)teRGhfx~1qOS1x0wHjgcdah#V6+P7O)!k>0%2I ze-q48Et(x3P=@FJ;)eZo+j!756{C?(d0H^g3^YY@Q*k*f6suRQz}=U-M-xcaR~5j8 z-i^%9?d`&%4aOyZUTiWF^%?%Ary$1;KtPF3J4`0)-T*H_CMpRP^~5oc*J1!`MhK|U z&MVx**kvGdV9XQ)Tk#G{USj`GFFA(~CtM#_QeFcl95>SyX)y+UWG02T1%<$L#jzb>L4N`VOd7 zy#Ew>z>yYpFA9(kQ_>zwB)X<7D2cW*_#%TR1Hy+H5N6L{6Xw?m$7u!n#PDW*%+d;t z;V_)*Yt-#sjZ{Etm5|dL>rfIzV2kSy=;Mx1gh$*$NowAhRu<#4mA#6S%pm?iVtu9#dMSiweIi%XTClV$jUH7_(yakWo(M<0RveQ7hK-&WhE z%8hwC9HGO3pBl=fscueYYZ#v}Ty+Y&&(@8FZFm~&*NpndN*_Lgy|1U>Ww%BxJ`e?$ z=_)P=%3X>!@fa1{0&*Tr_?^wMZ6eJa zN~}7kz~g7M4dV~u;~!81aKm^@Isz;5Obi(QS>pAtd#90*gZruo%&N8wq)SCq7+v|p zOT=Opa1Oq0WeaC>^ar4mQZ-AZgfv`xLTVxlP;QvI*giQvTk&H3{O~Zpnb|^LmVu~w$=B@j?2fPX zXV11B7 z<-4y)M;@m0#}opgK%fmSDVQsLzp8X`UZ00AQTRiWW?!_;N^ybtKtzA~x#FI!$V~O@ z9PyZPMrl5^y~3c}D;A}}2~B(h_E4Ehn z!1!})8G%A+l}gQ=(jo&?c$M9Vi*$TtnKvfIgGY4DUXM_SYcj(TVWpenD{VA|={?M7 zIN75xC$_8`+1Afg`=9w(hD?KqDu%ps3H};oO0+$_TUdg`jUzKy#y~}2>C;M{0XxD5 zuBC$G#>q?Qd@wK&Fo;S_7LvWRbpE(9ZO;3z>tlc5i}z2CUCPhP6Yw9g@A2J|RJjx- zC_6JIEt;lJz5op(-Px~%A?cT^jTpBEor8mNwb2MmVhpX!r=E6t)3+c~0P=!#RuUJ_ ziy3AbI7|vu+h#phK81Sj>y*ip*HnHF$g=Q_8&!(6c=rs#m^)r{TwdD>|` zzeBbUb3WRA&VTkw_oo0$O#Fcck}KY@AN*t@1f3!{Iz(OJ>8T=)08D{rmF@ZQX}=AE zl9+s2#uhk*zvf?H0At(dG&I4)Ceu4+N$6i>PjYSbl^m zbo{oKt3X*r?nUQHl*|9emHaC>+qO4ghwba0BO!>=7GxLFZyk1zz2GU^2l}U?13Zj*)cyTB8g)A_5|Gb1X6}Uo?8-|!bVDv0+gFDo z3R`mmTaFdCe}_z$bNjqB>Cb6tUx-?n%k(QJzbD z43A!*c!2(59`!=~tyc84!SCw2RHLXCI{gk2_+qP}nc6O4TWXHB`+w7eCbdNsw+|fPm|3%@|r{=0PYt31!R()qT4ZT3! zhjxxlgH^?Zmdc~x#&i&N#ey_UE29rszo1LYFPT7g;#}<~; zz^0?9!V}pE?Yy-)#~ow0y;+NEse%z`7)R8J;PF*c4C)8nZz)nqk)&LPa=Y%j6n|7# z_oIG|(92r6$gJjSd!k(h^^XLyied+j`hOt=D~JPuiEm zms3O#SpvGkvSjYH?ANbE_A;At)P`|a*eG^D6>7mNjB1+Q!!X@ zRN`()%-)!q#xorsA?gd%;}(?2$fpiB7j`2_n+L0bv?mh6zL3M-l8b7uQ~*A+^}Zn9h| zSIJaPlRlDwaQhxzmfZpE_iB8xs$4&Yaf-Z0XMDtp!YSu_m2WasNI|LBk)k75fCM{^HOL75E@NbPUB zUcxbV8Cy3uNgrg}S`jRpY-99XrJP@{mqjL6nJ+WXGHO0-tp8Ne2()=fz5ZY5` zEK$=8FibGLaWZu9o-^A&#Y!`2(;uZ}KP+9nt0rlNB=R%N2v09(zrHLBxZ4?)4{wS! z=C9j0uHp#i*jxGue4S*m$L{C2P4U}~SsF-1K3+c5z-u}23f+YDx7&EclIIYs)W);N-2Ns-#zXQIEyHtUoJDY{s|_`~ zCD1j;7=B3GN+c!4xv90>y5{d<^vrtuOiSbrT#F|6-esg&Ub1DA!_5RCF1Hy?4Mg@O z<*!hGR*M=a`hj6F#LxLM#tYl^=_*3PKkPS?6wkOkrIZG*TUT5{IE!k=&vvDe;ry$$ zYZwxg@fmF?3^;Gr{Vu=aE-f4L+E(9Opp(eT-mnU7eim=c(_x`8DlwW8xb~78KtUnf ztB|X3?`KxI4I@`VlYuOxhPx@_!ZC$U1sd@--LGigaZwCDRdFdYnYn5KG#C79nbrHV zW)t4pV4u%$QDMbL%PgWX+sm4b+PVzVpuo=esNd5&kOykYsJgBBB5>F#!{NZl7~s?I zx2?v7P=9x4EN=&)qKGqx`;%3qQRD$a+j)b91@Wx5gNjoDZKL}N6uD~e%5)H6vX3Xb zLCAL!EHrPQ>uZio%&4$#6Ctv zP*cp^)mjP$n?o5~nV7 z!#MC$)D9e}sg>CPwDnGPIao$v%yNsmvOy$5xx}FN{GjYMX{b{CMkH~|jvLN|mI?a7 z{;xPtaqmJyTMd z6XK$XkD5?bX*0jQt?bYu;P!a--*v6XsPUxk)Zq45rM?XcIFvcXXE)RK*!swS?9Z1$ z2^IQm$2~^73+oN#||@>OvOWZq(Rth)94WnuGf$>*6IM9U8TIBO$8bKd~*tn9rBnd%Cmji z{fPJMtc}tFQWjUY{&7m`C!Ir*&P-BXLKF;K))e~jX{UFR#)9!fy;7OO=huuyxH(6x zWl}Lu9Y%D8tu@OWV9xc8@u#0g2CQU8q4Q&fjJ9ED#UcL!+?@>x#?R3Nxi7em4BR>Q zuPTM3a&c-K+^z*Kk2M{ZaF5I)Pi zn>9s=>dGtg-qWV(3M7=d1$f$cXKw?)rndCqBB~VKM7yC&M*`J+fx>2R5pLad^+1OP z9OQFWDc7qk8Kyfp*k_cG%f_(Dw{WB4e(ya#H05+(SL@#7Xk-+k0%~!P(%F&%UEmlV zW$UKfD)3D*pT;~l1u;s|)e&edh=>_7*6mu=G{~TC+sda+!M29lQ-pG6ib{gXm6Vn} zOrbY%e_)QQTMdu@a_Mfs9>`2s$!p+WzSK_&nEN7HOf4?Lg7?naj&G2uQqnq>y{CJa zfHqnUU%5Mi9V=U42YG}QNFgP5Qu1;adhy>2#wasW2RF}$v7`B8pA3R;6s&*6BgpSI!o~ft3P}Cr{`4Gd3N@zjOk?PP!4&UGG@B#1;dl7OHqS5}<4qnRSO7rR_K`#XLM4vD(@RVa>Sz<& zWq=}=9TRm|m>M1Tpe&?1(KKZW@N;~!2ySg#MpX$`MzHmdV+TH7;P}y>FMwPU2IVY$ z=vK-Fhg^9|J*tatr0)W zs#nHD6$NbUaZBFsr6R4ZjD&XrvJBKLNhAWc5%7o-umLC*Cr*@iZdmjn87o2GNB3t> zFyUAx-dj{ju}>fum@IKfWc*qYFy8jTcCj0N{!c6}aKkf8aqeT$9fg1cMRXBFCw za||CsI&0w1bkv9K&t+%Do~maHydmwDG4blt8mlF3S9uYJ?wqSzMcitc#zsYyMp2HC z$(uyct8Z&JY%e9eggz{3H=rz!2Kr?#qQYiF;9n#K^b4X3}SEZTu2RmX3#D}xtGI& zF|&x$m$W=+_$sst9xUlRn|t<7*&~T=yzi_x!VL3-Y;5X0BSkxxaiEb^pYgEH?%c5; zQMeQY7z_Fx^w#X~@Q?MVs*UHoleAVo$Gg2xTof+XsWJ`A@d^dy2mK;{U~ zy`KJ~giunQW{OUllZS#KZYiNAsSG@51-_HVM3vvS;ZPzdUj3jRqQJh?7>zxmO<9c7 zy%!nbaO+aC$0P3hAUj8|pb1`Jb6SbuzW)oYUOXf)qAW#HY@aa~SX&RM<+`&?mshRV zLCK72oX}9TiO$lLs005trGR~vT)HGYh;cB-POBI0Oxbwg`fOPYx9CzYiiXLTyBHGw zOjFs)_yLlm3yW196NVg>PTpy52D;r=YivNK9hY${xi=kPpJQ7v|LT6Tbe3x}UFWiMqxwU|YR}8;C!Fk*R^YlY_DTo+4ZXTDP8A+;%($3J)U{M;%%BH`Z#=p-- z(@DFnHUVs;)4QaZgM|03r9b{j8l+(b+pJ5Bf*uj$RUV>@A=H_#P=^-UMV>@5Zo-bW z*AiXp=Bpst$pLWSHlIfcz2crh;VFk_ici zT}pdGbj&cuSF-f!f zeN@N-z23bAoaz)xdI$#Wl@t)nDsVYACsFm61k=}H0#v%i9?;~m?O02-xSW((> zH^`K;sg`3QBhHhBVJ(Yrh?of7jszp;TxG1ST8Q0(C)r^>oMpWC0NfQ}Po$H$8S{Zu zg*Y9td~ylaw?kyZgF3rs@ghtfQHKbXZ12^Rk5Dfe^>Ek}%e^%nu-!yd4TT~Kr`dz6 zGXvo>m8FnS4P|NVi7?kXre=VIpiumU_aM*c`uE~OpyA+qA~hU73Qv!my?VHic#ny! zF+1e}L}GePUnH6*K?P$d3OTFM?U<%o z6;hR<+vh#~*o3~OZY8qv-XxgQ0F-G(;s9<^iOwq`DLsx}x$Y3v9cgh6rJf%Cw|D@4 z3At&iHI5h?G$1aie~A1AOJ{|%?Sw=5j#WefWgNxO59Me=&Osf_$#w+|s0%~Cqd`K3 zZn%F_tm1p6`gtb8Jp8^qg+IJmXr{}j-k3xutw=7(S_Nmdn$(5cvYInMuIQ{BAY<_iUyM16zP<)nSKQdfMHLz# z^3lp*XI=u^gVc`21?I5+z->pDeE!|(G|RFo=4$#i5^(`fsp+2g7OEnAR(}wsmVg(P z=OXxKiAuFxhPgE$jhMvN9PCp>Y*76bN2h~L*VkD<$ZXxs2_++LfeeG7hBPX=iKF@-;-Bt>|+nQpuEU8@$YLmQi}0#t}+v0J{-xV0$smvp+1u6lK2zxe2bZ za3$Iv17#wndsxrq|Iz-`2huQ%P?@og7Or$%47Q;>6?gicwcMroRuzl_o44LkUP|aZ zI~DHVGn*le!PN!^cUXvo=wCx)x^n1l%bdK@PeP>t6RDx5u#o-!%5|nTvT(ccmcU*e z7Jfoa+K}_Wfygt1WXOdKihkN7qcM@I> z=0oTi3TiHuQU_)E$@o*AO;=#$QpZ)xZ2eVfz>Q|q%}-A)9|zQ;&0Cpg@DZL;jOuu* zmrW?8x6S*CJTmn$kY)$n{3Ht$PEyYx4Ec2_ZiTX(z-iD%knIm&tV|8d+2q~AQ~ z|D{SjDcrY$iAr~G0|f%3>ioCQ+Y;sr%x=X~by1owD?Tgl|`w*VIHD494*f9 zx3kV2K5C7Wcn(Gr^qKsh3MTOLS@?nP-xMM=6vBL4LN9OmgGRE*s#*d}z@#YU>b;MV z9th8Mv4a9Ss<*KB5EI-La^j*Ir$`+kVDxLL@Rbr<`g+}FyRh)#!{qzfh_x{W>QO{M z4sm9_a{$N%QRG7fQlI0fdWBQ?OMRP&-7 zmuh2}(~#Oa)FSY5+kBT8#VDNT>87R{w9EKC3Gm!Z`Myf~zBx*Z!#}kJa(g}rKFm;_jkToV&IcDj1NT=?~TkCGMe5NIT&Yr8xq<2hKvO(NGYUn8& zC`C}8vZf`X&3igV$k3%9>>Q!5&v;sw}_8hK(-o9Qa|QF52Oho<4a0HHHI+ zXCNiA4ZUM#VfGsB1w|zNiaWNk@kzA$$+B16(4eL11Q~Nh{f3FU1r(Wz-P^)B6o@eW zvbx3NwVw~`Ebp;FCrG`m<<4W~kl*y;put$Efc4e|tAXLsAt;s`zh$V2&J;sSfxVal z$d7|rsAW79w0dNer?~53U4465b$Q*tPdwHQZ^lUnTU#p>nd~peZRGeVFX9W!EK?%d_pq@tjqlX-)g;YmsS7qZ&`7+NwS zkxL~bk$HU3%2H);k2>M)dgSW)!u8#S_CTNk*pW-W0QV=b`A`bfyOn#Mek|yeI4~*q*vip_|EZ4DV5zNQu zJWp_gGwNcj9x6N#s`K7iQV3_%A1ujSfeu!v30LXO%!a+5akCGlo-P}f(WC4?@S1QN zG+{xU+GPCJwRv7}li57={4B47#+r}=zqMnb^ zU~~oPV?O>kdc$BS4L%iha?sPdY2Pt+z|tL|=&ezar8J~eOsa3UPTGxU!u8%6A922f zpshb0qMfb-d)00bCgv)(d&8X?teO>*mglG~VfgvLC#r2elR^Hx<%dM09~gy3=#Zc~ zHDYfIcCAHj^}s-VtnX0uCr?NL*8}eImDgk7{bQ|>xRh?0&`mUpZ_i@o%C$ti?CCSj z+Eq!`+5*iPpaHXGwnUN>oa2yBb7WO5)1XJbvRO@IjA=TOvqKo5f1Lhe?xe|k)CUoM zq5&xpLFgW_OyQv_F;D?)&5q^XqCf|VX*o62cHk=79$47 zEac>fm)DGpff1Eo{~8tW!;wQ?Y{wSb@BNqzXkUaaW&}9|s-_^1a7tZhn@S({v-S%U zqFR3s8&2cz>QZh~$hSEEnJuT3@~cO=A+1JAQtQKR{Z-otoG5b1oaFD~I1P!jQh~zZ zOVdpDoYLId3~PfZ{Rp))jo@lF^He&D*x&^1@sZ`p7uq(cP6oQUYL8is=gH}P0L9tO z!^l5cGfyjr}&ghh`hub!Ke19=qRVPX98agQr@* zUk)Ti$vb>C(-~a*BjPM$uZTcuHa2NWtCAVfUUee%DjeLC$GV8JJ0PL76U221wv71> zJ*Si^QrzfaSA`U6KTEBSkJX3_T%By|I0?G!GP;4YQpJ;Eyv|H^bx9KEEA-N;GK=Z- z)h%9KDV^jasuduV`p$^#(BaUs3@*Ja@!ailE9mR!aPGBI?O0mH8hA&RvnWg}x@(@k zS(cO&prO#4)HGM|+RnGpBtb_@z2+X&ylb5xc@;KCCB)U-K;F;F9V5HpQ3mnr=Y&YN z+N4<`$?E6_%o@<4?=05N`vu9giCz{gCocd)Ef1MDmZ7w<%?|<{ohiLBdFTc7Gc>pa zWwK<2muFXNQf2wqPfQF~^i}_6+lSSJ4y&=oDtmHLki?EF{IQ;S==0g1iPVWmQ#;tL znAuU&*5Hk<8M7+PUC6!kVM!^02{P-$jgh8{+t_KB)^^>ZF;nBX_;3Xyk#0CW;4Q>L z`h8rMcA9CnTL{WMzyKlx76e)X_gMze_5Bej|oViOR2x%b#yBLMU)}G+CeF}pPvD3Tl4l`Je8m$XRrh`eTRg0EG;#Qtf9REd7WBiP0 zuVg19A$l?$8C7GqpK~F#vYxg^O+t>L6j5b)SD@EGm6Fpa5D|UoLm>&qi%jXfasLj7 zv0M088ht$43AF^&5Gga6ju!4;J&Aa}{?zMVFA|mt=Lq{_qaK7q#D18F1`Z){4F$x`W1Q<ewQT}RzYaulxjvo+4g0mPb&ye}jy3s|})1Hn6lk4AzPK0Nu&3cKjNg? zq^s=s7%V@_SaG%M zBjK;~(eC%2kVCK&2ljW<=Z|KJfg`sq@}L;+AmE5Vc7=hIP`nr;V*OoEaIZ@8A&KBX zGdqZ3VS`G#7#WXL8O2bzZ&=Bo>k(2(lhsPbUBW0n31wz5hCd%n(VVUR`-9pPK5-_V zdvWkP3`O8qQXo5sV9cN7~HE5Tc#-tp@MwKD1 z)b!FUhtaV$ZiQX5HxeoR(ZFn1Fskb@z54+LG|@?5Z!cvpYrh*Jg2>Efv2bkKQi^FiGCuH;>OUNI) zy{&KAaw7YKrsB^9!F9o8gd_*RGw%CzcmKV1bz0zy!M{;qnid&;4n;?YLZiEX8OVng z=u&nl3QuO_y27n7?~4{^tybiJ1kQF4VvS4q$``bG>|x8@Gf!4tbRLsCFA7(%ry)+K zKqkKVt-p@+Ln+I4unKDSSs(;UgKTx^5ZK=ktoJ1S^kp2ENOChD(otjcWFXL>G>r=Z z)cBao<^~}lch9r-_{4bc`;U;d3qm3rBt%_fR7AdzcvS~%%COwn>w4i|@QS6!M`nQM zqucwdT9w5`-zR~NtZV>q1~+IVLr5^N`a6)24>cC7qN-vTUo5a8hJYZUAR51P zk$irljnFmjib|u$BXcm8>O3bzxsaAE_N>Z}dJLKBoWG64;4w3L@IXi)LG;^B_j>dq z;RzcWo)}OuMZag=I$ds+dWOR9Y!9mWB@|{@q%0GdHdC`hMJO)PW?i-inu-vHi@aNa zJ+i3aMnzb6=y1bMhm)!18+XZFB$`oXCMv2xxW-Op1e@iFCKAQM)L2`W#&y779wpe& z5S~dAh0G_Bv4_xlDn@97TMyUsJ;|YbF$9s}P2ryJz*-R9e8_~G&j3dL9H?(hHWnOMQbB^jM4B<;rI8}4jpm0F^af-g}=@n z*8&E4R<^eVng4CMzb)T-sR?BcY_D>_-W>#^7lL8Ao*AJ+?o7YaL%621c}2HEJ_koD zfh*WMj&S(NhG+fec+NekRuVYc6#lfP;VY!3B6%(KNZvdC%VVj9)z3tM#j7qEx*wlV zQ_%X4`VlhWDPN(tb;}!U#B*V{< zA=u-gap(TMYsQrzA&*dTnJVpiM(z?#hOzNDhxb%z%c|1_h@+oWqAYi=c(F(8EH&h~ zwV2k$61cM6K_{Lug$h#u@ynkvRMNhq8O5pU8i9YZ%+M=A%UkZkCpk;xbfvB?bASpB z#Iap@N2jqofKqMw%ACfUdE6`HjlL|s;s-fZ2{gx58$G2~fD1c7h-?F^NZ^yj`-F@& zG^k&_{EVujw7}pK$H6PvDD{=K5}a^rku_nH6R(j{cW0}F6b=wi7qu)_1vn0>_9{2f zhdhUkN(+V!eD$rivUT8BkvjmAwjy|`0cF{}Cw;m7CxR2-hu#xbjxH7>Fa;4<%gEK5 z1(~DYJ7@1b^)v%wErhYXMreGD-k`v~Un01Mo!K=o-@W_>87ER{0H}AoAsX zfe_=mf)m`;DXxugrcyFdoNq%1_=gDmGI!?fK!6EzPLgy(J=9UW@a8Svg2YNwoF8bz zAIN+BJiBT60IrP&cCx;dvh@Co*qT!1^+O7gqy-$YykvjGq`J}*3n4~h=PD}*acJ7* z4;30`+$JOI(jLMC8OCSChCtH!g?x}EF~9(xwtAlq09#d}f9zT2tFgR74KO<}$Jhsn3t<&!XlMo>XI#D`%z9k+&-_6Nw-& zs~WcKvd3?OdfYaWhQ=%QIfFFjp5D7du^BRbj2aEcOZimcxEGJ8E~Onal6p-}I`bV( zicLKbkcT`Loxy$a$w`8Mq5uE@NPu00wY+d`EX+L^06>on0H6SH0FDlZ^iIZ(PP*nc zj!ybkR&*vD49ZGS0FXeGTHWgN23==2XaErCF$e(gU%L&pHJi0x2;N7kRv!p*{uSpR zyM16Nk>SCkNYb-ncO(pGa~R6P0tK4;SDq;exbEhE8D^ms*8IwGFVE9C95stq&aGLw z$wd;-?`~M=LlVXBK`^arzRFnlD|D2KUX)mi%3CJTVo}?5tTP?jX)@0|L{4LklB7aX z=f1ULaZTJ45*?bae_U3VfGErx$tPNGkdvC9(#y>$Wjc2)HEz!1r!1H{bPa4)zTUl- zl%we=d+wL4ZqnF$wU=uUehSI8Hf*UrYG5O#|PtA=y zJ88w8SYi-i}T9`Qg z_%11);fmgsKm&%%c;#U%y&eQpq(@Lj%qJd|5pO7Qg{1_96QWE9)Hn`x#V(_?kvm*GW#9BK z3j7WAY>qTUl!jpwsurY7bsU!FTmRSjz6PdwlKv_N>CYwBIBfIe?GSs3=%l0${z=q* zCG}EV)F>*n;b3L<6i3N?TsboW(@Co0^lb%5%WMY!b&Z2ElQ0BA7H8Ie+aSfdSgf-o z&JvdI?}jlv|@NIF4dzq#i~SF?e$wcuLOCzF~k^-2iM=cMc6f6C*;n)L9s99dgrn_f(zj~O*&nL zk8En37pMt-Iq_PzGXex(pO#qKHj6Rq$L|vQOz|LryhA4;P;$Mi0YptKNJ^W>T~0x=gm&0}6u`uJ zd<1o_F6qn*$js=~@n2(WbL-GQ*_l5(=E`ik@3=eMMLRr#cH0ho&A)7QdI)2208xy9lE!sc4kMl0=RY6I~yn zYj8X`Gnk*Me-pF8{ib<^ulR9GJWd_zwb#dRWJ#{%{75|%gb&?WsD=I~p-+`3rW=SN zAjHARu?h7=QKLX4P3{sIO{CZUlE;|y4YlKk1#rUJlE`8?^mTTxU0@7ULORSFmR2nT zquANcJn@PcpXdzpHd6#fBF@hPn1SvK+@wO!@-_CZYU=T+YHRIqIEX(G0jMp!%#?5g zvgbYu@4|uxMZNP74Ie>7YFt}5DY9whn#7FC=xr83tq}rE_~!cTIXC z-7%Q0)x&Sna^3hoZ@*{WZQeJck6MxMwQ1SgJvniDWV?9_Y&ye3=bmn^o$-9N$@n(0 zr#$yf`3{~uir6Jfa;{xhzSlveex&j^py*`TL1?UNH80_<$JCrolyq1;y5<6Ltoq;M zk%|^U(i<#kHdJ6YZ2e@vtvwu|iB32Pi`wGeRedHNpe5(fm*rUA^1m%glck?J8o;cf zE#yw=3eC#>+?)IZ^6}Id_gPAFeH9P(>1!we18hppVHE};;*t*I5sTdGIYp)Lg(tM@ zX=L^uzy0t?owMO8d*<-F8qNDp!>JDMi)`M)&O$4>rbx%9Xi7y$4C1puJ`jo9SRzWWbRN?b@pMp5LyT5fp% zKceTqx17J|8z>H1g!p~yyuZWiznj?PPj&DQP+H&8*u>n*_`is0td0K}kN=%m?rA3< z7CeRl4GsXL!~bXB_#gg5R1gsmmj1^=+N=Lx3;&fb#J+PIzJFVn@ZJ4r|JLLp|LOC8 zc#itkc2>sU`GcLa6O$30k-pRaw%@%Q8W#JozWe?1KiN1p|C7z~f5hJBQM~em006jA z0RZ^_W;Y!S(0}>VKX%*wpLi5^X||}-HRQY6Te001;r z0RJ~1DDtnx{=cDC`cB4%|4TRhA35H?Kc7rB{}BIY#`phaE7-R${mVCD0I%O(;MDZ5 H=luTyJ8|gd literal 0 HcmV?d00001 diff --git a/docs/index.html b/docs/index.html new file mode 100644 index 0000000..3f5ccfa --- /dev/null +++ b/docs/index.html @@ -0,0 +1,137 @@ + + + + + + + +DELAUNAYSPARSE + + + +

+ + + +
+

About the Software

+

+ DELAUNAYSPARSE [1] + contains both serial and parallel codes written in Fortran 2003 + (with OpenMP 4.5) for performing medium- to high-dimensional + interpolation via the Delaunay triangulation. To accommodate + the exponential growth in the size of the Delaunay triangulation in + high dimensions, DELAUNAYSPARSE computes only a sparse subset of the + complete Delaunay triangulation, as necessary for performing + interpolation at the user specified points. + DELAUNAYSPARSE implements the algorithm in [2] and + has been used for various applications including aerospace + engineering [3], HPC performance modeling [4,5], nonparametric + statistics [6], machine learning regression [7], and graph generation [8]. +

+

+ Read the User Guide » +

+ +

Publications

+

+[1] T. H. Chang, L. T. Watson, T. C. H. Lux, A. R. Butt, K. W. Cameron, +and Y. Hong, "Algorithm 1012: DELAUNAYSPARSE: Interpolation via a Sparse Subset +of the Delaunay triangulation in Medium to High Dimensions", +ACM Trans. Math. Software, 46, Article 38 (2020), 1-20. +

 + +

+[2] T. H. Chang, L. T. Watson, T. C. H. Lux, B. Li, L. Xu, A. R. Butt, +K. W. Cameron, and Y. Hong, "A polynomial time algorithm for multivariate +interpolation in arbitrary dimension via the Delaunay triangulation", +in Proc. 2018 ACMSE Conference., Association of Computing Machinery, +Richmond, KY, USA, 2018, Article No. 13. +

 + +

+[3] M. Jrad, R. K. Kapania, J. A. Schetz, and L. T. Watson, +"Self-learning, adaptive software for aerospace engineering applications: +Example of oblique shocks in supersonic flow", +in AIAA Scitech 2019 Forum, American Institute of Aeronautics and +Astronautics, Inc., San Diego, CA, USA, 2019, 1704. +

 + +

+[4] T. H. Chang, L. T. Watson, T. C. H. Lux, J. Bernard, B. Li, L. Xu, +G. Back, A. R. Butt, K. W. Cameron, and Y. Hong, +"Predicting system performance by interpolation using a high-dimensional +Delaunay triangulation", in Proc. SpringSim 2018, the 26th High Performance +Computing Symposium (HPC '18), Society for Modeling and Simulation +International, Baltimore, MD, USA, 2018, Article No. 2. +

 + +

+[5] T. C. H. Lux, L. T. Watson, T. H. Chang, J. Bernard, B. Li, L. Xu, +G. Back, A. R. Butt, K. W. Cameron, and Y. Hong, "Predictive modeling of +I/O characteristics in high performance computing systems", in +Proc. SpringSim 2018, the 26th High Performance Computing +Symposium (HPC '18), Society for Modeling and Simulation International, +Baltimore, MD, USA, 2018, Article No. 8. +

 + +

+[6] T. C. H. Lux, L. T. Watson, T. H. Chang, J. Bernard, B. Li, X. Yu, +L. Xu, A. R. Butt, K. W. Cameron, Y. Hong, and D. Yao, "Nonparametric +distribution models for predicting and managing computational performance +variability", in Proc. IEEE SoutheastCon 2018, Institute of +Electrical and Electronics Engineers, St. Petersburg, FL, USA, 2018, +7 pages. +

 + +

+[7] T. C. H. Lux, L. T. Watson, T. H. Chang, Y. Hong, and K. W. Cameron, +"Interpolation of sparse high-dimensional data", Numerical Algorithms, +(2020) 33 pages. +

 + +

+[8] T. H. Chang, "Mathematical Software for Multiobjective Optimization +Problems". +Ph.D. thesis, Virginia Polytechnic Institute and State University, +Blacksburg, VA, USA, 2020. +

 +
+ + + + + +
+ + diff --git a/docs/py_delsparse.zip b/docs/py_delsparse.zip new file mode 100644 index 0000000000000000000000000000000000000000..f7605e345cbe57b5dd792bc35e93bbe074a95bff GIT binary patch literal 119435 zcmb5UQ;aSQ5T^OHZQHhO+qP}nwr$(CZJ)OLwC&Tqe>RhyY-Tr^xv9FSr0yz}Jny3@ z0|JT)001BX#9od{Tq1v^(1`&6gL?n~4uA`A^m4UyuxBu~HFBXhS5t)ofH+(>8-zYL z8@PGG0DwR*KmdUMyWH?;c^rwi+&$5J9_E`EnvMr<wJ#RFSonqQ_9AbSlV?OZKU1sA*($r~jyuoY<&Jo;UlsEVV(L6?$0BIPkCW zuT7Q-Josktg0Dbz<-}#EY#`(g=6sBLx%Wo7@Hj=G2#Qtlf)A}Q81(n{_OAMIWO{bI zY<(ZjjCwhb2lzV~6p*)c^~CV`7m4_;Q5Wzx>e%tb1kX>UnJU@e6<7jN7X$@|gdg z6&vH^6)m-Fk5J#_Uf(9$yzS-n{A`k~cWqIiylv&NPWraPI$Eb$c=QiKwOvlU^ii`a zay+4r62)x!-5<^B1-m%mAMAfzZ}qs`P2S*iJ@lP(XYHm0U47jeA9jNas&2xtsFXZq3rR%l7WsBcb zEn2-Q6>uk?&&_;-kgf&eJ+8dk3b}o|WfQu_bl)Vlww^zq+p{+nl1rk>^_O@@P8`B|~{k?|BQP(lL-+N|1$7?s6me>x%_x5 zPexFgaO*5JDDrCqSrLTPl5n`R8fD|bBSXQIIfrj3MiHB&kr4qgHe&693f@PlgNoNx zRx8khUJ5~*EjDJ;#H##ye*skn4H3N0noYgU#-lJ}lO#S-=$|4}aj0fixlvRREq3wS zjmnwB0Z=X%U@H>;F-z%(5&k%3K0o{W$^|5#CH*%gH>h$&w$;k2bxWa@D^Ur1#Nw@Y zKQ4)Xj_ikah{{O8Rcny-23wCnYWCjEWYplSgaSr3i;((qJQBKX41Ir~sh+_BoUaFF zE?k3TXGN~54kr)khv##1FNVWPrR{;_k-g~)gh+i6C@^=h;fL5UPzGev2I^TOcT~{!!OrSuHTo5ePE{3y)ftbJG(HY(}96N@>Ble3*!v(W1 zcWR|X<+rDb5OUg*Pf;97QM^nDtF9c*idsY<&Kcz|1D|FoN%>f9{Q#wEh9sHN1tA^^ z8)Eg)i4|q3{U5yQxmaWD7-Np^Jg|gmH*I~Ft^L3==HNPL4#H1{TLZRkpVMkOsXXFU zqt_a$v{KFe&4iF@5X64axDbtzf#K+T61_Gob-QV`oapMhMr)b+Kh$+@w0`1RQLFc? zAF}+!lk4){mD!T-S8>P#U<|-;fj_O@W*gwTif-ibzWQFI)CtCE64KH@d8DdD-r~Rt zBv5i9SVgGO`0)9Q*%y(0NIp!_D2;SLA_sA;6`;=o)ZoM+5vsdCknT;W;srw1ZNMG67P zVPKHqH0IOsjJJkp0Q|f3<3Md&eREwU&2K&gD}LAXgpss0T8V9CtBYW26PC{}D}D$a zM*N~9r4sANc6`@FBVJ(806Crbc4Kz#L~O1G z58096U!CwZyi9SNAKP;qX}Yv>*H$b!sBH%^tzr42Pvr@`h|lH2XmEybQBhst<^rW& zVs)UrNT;9ve>Glq?GTD2;wf#d^ew?AK}Tk4j)LzcdP7Pn(wk>*{kJv;^M0DG(Kmm; zAAK6^@>8Dry_V2;xkIzI4@aI$N8rC^bmmQ!GmM^$-mu@Tg%IOOU9o}VnY`!ae=t4))7+1wG5LJRO z3~(B|0`^Mo25y%IQe*=khu|Q?LKfG80<`bXgA)z=U6-sPA~o)PZ;Sny?hQ`|f|ySq z(5s_+4PrL6#Nk)7gG3)gOgsjOb1 z@|;|%>_~fK<^lwJDu|9ph~W+QUKOF=pdLs{?ya|3l}R_G<-|NCjZ{F@Do`r-2$%}w zRtl%_Hjmm*Hrv10Ullc6!Lile_eMA??T4ni*`~VKrYK|p4MCteav)4SQ)Nv@^4iVL z<=51uMb{ca@|w_&2}q)G8h8q877CYqN86EIoh|is8BRyZIK~#7j@E1}+Nw2gq&U$A z4Ueh~5szx+G_{)YVN%v-M;U}cV$wblWNDZOj}uwGxOjJ=_&K#p5(u~0fT@3->cxD# zgHo!x)(wk#&omceho3L7GX_@_2*m-DkZBRAnLp;O!OL&=lNN5~J0_K>e@wWd`XDg3 zwM#-S_3G-qp9#a&lVoB4GK>5Jp~5xwBJu0bGPvGjICSP&{v#6u6w@fsCIg_c434n4 zWZd6qO`SdW>%)_FOa z#E9!YnU*lfsaIm23ey71@SZ`i+ux?p%>{Bbg`1j<>Sw}&TYN6m;Jo#&iGS@lQb^ z#W7M^1QP>vmewMYEY;9wwLMq>M{}81iD34O3@MPg)n9Ph)CEC_98|}+VZN|=E}}#1 zx;mN8@gHpB`lbOUqzz75s$=;s-04j9E<7@kNw!Ci%yA=j3IaRHNwg*_mj=oCJX`U3 zv|Ax%4Job(t2NFajj65_*;~uov_u!-4-)|tX+MlqZ&v4}yA(-<8GfICd4BfGEE*r9 zX*%V9lWOAKy1T|$Hawc-9bQ`5nhi+oSrl|QT&AV%cF5#*QqdrT?jX!h@_~rFD34a5 z&i1b86C@+~nLy+BOp#uwLsxK;p)V=+LLgJB7wPr!gJ?9tq_KS?COmoN4UG~tK6CSL zpjdePghdc=2|hE4d){$X=}frCINA}U6j8wEDP4oqq9qtYAq7Pi>u40iEn`;+l}AeNes?@UYT>uos=;X+hLFy+_mwrg)X8|m7+6J;-{Qgulek@7s2 zkLNKL5LFl-!LsNvfQo0J1ob)ZJ2>qM(XM-mZf1$fL^Rhb-G?e&yQoJrlo=bVv7KnA ze^hVbIyHfWn{prUp@}k zhun}tycSG6S{M8ZVAnf7E`oZXysoxKTwE@ej(46IzOIAQpojIe=^bjR=Ljwq+7-Lx zQ$)Vxxf{@w$c!u2kfr4l(!~^qY)3V?nu^Qs(P5N$R~D`uYVI5&5Xl%0hwCg>n17O$ zcomD`u#iceAI5e2`@=CM-?vIHME574(8PF(lW+p?BO}|YVz~R@lwVK&mSWuX`)4rCDuHN6Wi$X4jNiy2B|wUy9EQ1g)kKxRhg;a zf%t;MG3S)8^0a9Mc8JSFkOy~2bLrxis7q#zVgph?>?RYtCL9J$j)dW%SWQ%v8EiTi z-t9FBZC}zgC5*Fb^sb!y8DfIiS+Tv<7oKSBxn`G-M*zc9SbC{J>GlsYX9Dp{-Bg8h zBtO~df~y%$T;W*ON`CcyH9)+d2eBeiF8V_jeU!-cxxjeVFzjFSOr2rV-oHZ_aucd!bS6oa zQ|8D!Yr6zl(H}na@J3+mD7%T{MjN{t2a-YfmNghg>8kTfM=IFn_Z(j-=C9+Si>7Ky;5)SRfy3JDaA7x+d9_n9;m=$jL=&oTD_Q^7tl zH-N4v7{UNT7i*X$oWdgL5-f5iLgMpqJjbu30Qc<~Hr2mT+@NFW`zgNd)ND&JAK99K zY?|D;4Ppi$| zyx17V*$`E^WGkZ397|o18(fhZ+$ByO9jy}O83){wlx+2cNA$?FA`=DPWugZWjk=sF zLxQUiuQ2(5CYjErq%-~`xIz5Z6EAk#jhuDVi4?!JpJ{YEp>=q%HKTz3LD)Va%aVKH zg#+F};EGwo8|js>lA+>$`>{;VPA^vE++E2Sl>IkBTi zaVUrUh>!57hfW*V5us{)05N228L|3?f1!y z{ukfBWGiJV)AxKKSfsnBp1__izDLIsq_RA+IiIkWMe#7YI)ShJ*Pq~o1oVP*zz zn|RQ}dY}YuhGEYEGi~w2Uq3Rlx#epFudrW_pTid+{cCIhjw!ZIacYm*lfB;?Z^V~D z8%Vu&q6$j_N>(^fI)6n%suAhk(2haUt-|DRu4a@knmoHtP~dU|1fYdv7aV%WORI?9 zcq?v4y1@1`J|2{36-aa0T@>8#9d~>Etecif6pN2bIbMq&^3V^4C7$YY=JwDq%S585 zE+))a@USXup4uaBBsB!s?!Ykm3Q2}QJts1tLKTgm~-qGA#{;Rf<-vWiAC1~EIfOX z`!gZD89ptqiTX2lny)J+IlMH(^?QeaxKjFTArMoxEi#K@b zN=*OEOM*l_rxsA!So|Rh=OaFvPeT=!u%_;liFeT|z}7X;RsHOf-{|b(9$@t(Zj)d5 z&WC2GfZ`Kq_N+ggAzt>V4xXZ#rXu2mOT^E4a6_Wv?YOyoT!@@UisMM?dWtn$mN^7W z*&6I^_5me+P{W>m0a@{|>Dp0tikh~RHs0k#zBIhi*@)v)rwSMM2p|r5l+f*?xLkhA=+REzcyx;_i@x`XYB~T{J zd9jodzSyJH@Ef1{_Fr}+9_sCO3@TaD5uufI3 zo<%ijt}~S+I~nv0SwxPc+N)6n)BHPT*L@z-yK`@4qi9SYVN|w$s*L-!iv22dgUjgV z(Xb_EkC&(?$Nb`0F+e(z#&+Uokwh!?;t5t@*Lg!6)DQ@Vx;Y@acqkmnqc-0{Wh>7! zF)eUjn!Hd)3Df9AoM_ufP(~r*juS-7t4SW1^<^5Yjk|#;2FSR$se&jfxrok!b}8@R z8innF4bp+?X#>p^at$_RDjg|qCv~zoSsi}njSx-zim=XGdxot*J?^aBDy^WEC5y$S z&2XtT=PCL!T#ZFT@6gwz=?T4o_JgI`lx5h;9^0f3wSXwjvVcef-Sl-9`%!W-as?Pm zC~c38Ls~^8%-Yhd3Z2a4xOsFuP1c$^gBeGIB;Z*344969p#Wzi(k!P}1CueDEanZh zM}+B)4JYUrq3+l?zRa`ZVidSEN8tVS(VN{6a|~z)cS?TzQRUI zSD=C<#~^Dop6a+{x;G=7i22s;@1O3@CVLz#!i~m7JBmD$Y3d1mvp<8Ux^aJbV=n%1 zj}9GS1@fJlv_1D7)X9s8crh^SnFdP*ko_uM(uoCc#nP5zMn?GSdfXace|iwxGZ+b{ z2*ajUp`7AEiIDvb1pIv;@!T6D$UkSyZm>UU*Z8hxwP|=rn5v9Wj5RIinN`RME4%3C zUs`EYK4J~JO4uYfz=Eag5u32m?BqC6%z~DG7)lTmX-G#i2+ah^4**4-0-7rUeZf%X ze#xg4>p+E`v?}gGgG|W^j&aY0N(a@iA-xID^%Uuwbz{LpZsjrS5Ng?RHBzaeF8^NHMJFy0o&+Igl6DC_;YCb!U4p)n#`7?{Y zp~yu5>U?uGq2EJiVqk5)q;tHJXcLuPtdDpE?9Qy#kMy?2*C>S&o`dHoySRi>{9!et zsW@owQKaeCOQ(MM+AoX|Vs7YY4?C4?xo36M$rwn+k~P({vzMT|ok=)w+E`l%8e`#I zlL}AKb;h$fbF%o<+Onl5#V>wX^KDth-7p+;$;(`fRegl>9PZ6|$Z| z)>6hh;+T1?r?O+fH3#e~*)aYc*P5E%n*KP3#U!lc@R_Zijb2H1w`wwl9V(}JM-}}8 z>_t` z7-Plx6>1YDC@FO0vH8olRe-d*CT+S(`U{{5_pYV>Qdqo@O8$FgceJ-aS&V5syJJTC zWz($Lc+B=#S__l9TUh=RvSQ3=(+XLi7x6y|I=AV^)N#f25~L|dAH8DTW8F* zW7XBd1u^x!G{aJX#{#to7K(Lh;M6M8d^1F0V`=-h>sf5BNs@ht;`O zHSRVSrIxyPm47U{iK52|peVrC{}lo#a(-l4TfQODUy`9w0n(w+bAgtYCN+^B7&|&7 zq32`Z){zKgp$?_o2Wx+!E_460o#we&NUkoJ{);pEO#_awar;y{AyWp$QMo8(Y9FB> zChOhz;%^&)rrP0{KSlysy`9+|(nt*XwoG0#NvGT&P%WQxdla9!~!D8CM?izAX;=xFA(^kyu9P`L6H#LKm6qJuCm7xk?rY#Rrw zYFBv8^_^vG3Z41NA(XUQ{P7v}F)Ov{#HJ!Xt1w=~CbhEDcNo}5vJEjPnJQ6uEG@cb zXAaAW?1r3?%Bm|c1NR5kwpTS;tr&_d$6~|yLtPkj1($#sDxvlHt3-WX0mhaQbPR$-4p{7ALGD)&yx)JY=h%Rx8S{+TleddgiF) zTm|S}Wu1o>`-x$C`;lVqYn}t&$6LLWtbfy)Ty|0jf3iD{%^4LNk*p_%4ca}XFDibz zZ+ddZNK5p~<%Yh|u%Yh8N>5l^T#)7orO_|30HGG z;7>-LeQuy;Wd-iSHt8H5R{DM{MLHbWg~lj8w3%Q5Y4zWkRFHT+A0nXFfCc*fC&84W z8j$gl4k2>z(h2cGT+d_4k21sK<%tgs_a73o;%==@P<+JAIIYgq;}kp>2zA^i8ji0U zeT2+O3Ff^npbOr{OT#7oIiUimJiCd6i$JS`m<$Pr@5yjztqr43jHls&7hvbu2jrq- z8jzWts&Kpry>LBN!Ba!Mnc6$rR6jtcUd=90@{|9`i6aP$sMvO`ctYJp6WIq0uo>k~ zq9MhO7Par9CHo2v%}5q1MC%OIAkjJJ*gr@#nM>;h6S(0@R$^jW$A83O%UcwV) z&#*Y7vL#-r;xac;A~QJQw~5A~AED+UA)1aMBbF_I1wF|R3)jwqpf4;x4FNw5SV0;> zL0a%a@*#|s%;8Lt-7%-o_Suj=(*RDiS#B3-v3)+djON*#3D`$l)t)VRlqAu*E^O0! z`VMzLHfO)7n3SYDH)z_8Cf{iCXJRl{6Gz*uE$X&s$*z*Sutkdfjjd5lq~>WAFt8FVOl-@WG}jO5|!IS2NO) zq(+j$DvWza5_jKGMr@)Sh-@(g^885BBRf&jWL%i%W7Mt2T#uXIun3H4NGwx`bM)tj z{=(~ECvKas2{(tuy2Nauemz6pF(_1JGt;WXafV_CBA4O^aNvZ>!Z=oFjp5A^& z2()Gq>o!JcSOI`LtTFaIr!a$ndI&}zdB2zI?E%EqbAaXsPbYccEJ9(H%KCoP{CMa$ z>Jncw;9r2^|4S}`s})@MVFUm&V?Y2n|5Gk8HM4bbG;($^GcdNYH#IP!H|Jvfe^it5 z>;F|X(X(?o=5+qy9{~1HlR6PC+04$tDL@Ih-^|9_&~B#N-rBCN$tf0-Jc1Lud^b*D zPy5Zc2ap0K7wgkDh#~4s#fc`xjj!DOm*#?W6>t+Z9ZeQ!C9yQ?dI*uPmIR?G<@i2? zP&V>D;%Yu|!A)*DQ3d&YpC`up=7it<00y{}MEQ<9|K21i;8O`13y!!0b4LeWbKYB= zu-{?V!Od}-|hAF_`LJ>`gacCK2Lsh#O$qYjT~HW^yIW0 z>fP15Es=+?cXbVXxjSwBx~KYGHz(LFJEUx%bZnnwY_oUuT<@16m>F~*$>e-5_k91Y zA$)DP`+1StDcXn6k;=-ZF0+d7Z1$G7t`+34XO#*u5Vr>Bn~nWKwP?@vZy z>iHdym^iX_`f@ z-4rG@f0k0MktD|$OeA`YUW{TPQ@FQoF|kU$F~cjA&2iFRzCdhQV?#hMzd#R7@?1{_ z45NBR>usExO&M#Us}&b3?fH^QYR{gmrV2*)YyM@dfS@?9B9+8|iDe2%BZ%6*j=1#w zCaraI7wrVqV*po}3br;b|5;YNMEadKw3f)r-vo?`46?4X4%vpvx~`M%0ceE5;+*eY zHZrx2c23PxJ$Zo@dP;;S^Zdw-|L14{v4ClkSsn5NL;;J*hLi{ncd|8iYo{zTv57b4 z-9++{uqo#~5nJBE^co^Geqw$yNQV$9R2G?j4%Z<$In*`*+-3h1lrRnV=U*@{7kX5A zs;=TjG@lKSRf&mLO6L9=5Pu~rG$U&~k)NEEus1h!uEZoX(`hU3jNUi60WL!qNseNK z?@i(p6{15*4ZQ#FShVoI4a&FgUXVe<5rN$!){omJT|nISNv%jY-Xm9hG5ZG={@+s2 zg*q&_dneovjlx@>6!^dR_;?ZJC%jsWYmxL56VUj0laV1{ zCmVsjkr^6?ZdvoWJD@+2$~dBk#hv$6El>QU3X>#UZ+%Q~l^n&TV+_CBOAkU24nS@t z3nv-^@9+iwb`_umw}7}7fHdUfLIR-$FS(12@Q6JA^>dU>?gVeVJoJEWA#GBbt#$B( zqdky9B(fzh$Xh!j0E;xi=iwSD8r^ffofyW@!_z1T0fQhUrmiF<=5+~blX&GeFgP@y zmIJ&l=#tXWACZ>BFfi$EoJCzxvxLeQWX^*ZfD$1GH5@>)j{q=LzbI4_^gEIR6vh%1 zU5UAWj%ig&C(2cThUhS*{X|zi8}Ozfm#5E3q4yC;lr<}yN|&#rgfSyi&j4VzoWt-U zR4ic8h$wTeoXMyr)y=n|0YblAS(q&WubS6fNLj*Bn7qPJ)S74DF#<9d(;f;sUc z%EJ_|Ga`Iu7HMccWj4879G@E!(bKMg=}-xA<+C)IZm}Ejg{r*N`l!XFY}; zK9$E30V3b>gU$nP8dY}mExf#H*O2@0WU!|rA<{LlP&%~Z2XBb&V716ZxeelH1FtqI z1*aq$a71`jV`dQ)m`tgNe+cCanF=iH$weX)WkeE8WW7=7TvZnVH=?-}djSdP#opT# zCUEYxYG#_35$b3OWUB&Hb?K?AC4?~1hl46VR6a?l#X$y)H!w-X!t0^d=@dfnT@wnR zMH*4`&GHKna}L6g61c4Ta$+St`a>EShDvVKpg;%16MP;d`h4sR@4#_#w}AFdSCQsi zQLRX|>1WldFoPx0%u5}V1$Kbl^`{J1a1(bbq=p0}Xm!FnQ7h=EM5ASL>}zza-5J_h zm+7f3OQ}mUiDpvr+YE#hxkV@79Tf&%7z}oIM9y$CH$_d*H6i)ozZb$x{`TlA84ESj zW@v(TU2GsZ!^GUoOB#a@l}jKd0L=~Wl77hw+{+7;9cgVTRZ5L3#x4wXb?u*a(;Q)B zY1K$Aq0IFMxzH4Yrb43h%jrcjavI(&nX_nOGk-BM^uhO*n^yz%)RA2q*{7B@92FuY zRH!(gGw)HdGIrd?Ns5M-yJ?kkjgMYQQ@y9AyqU#wIY)p|#qU*#z`~!9V#}}oL}`ka||>KS@`u*7|-bR`*-#+ zw+W$Fs!G*}9-_DZUUU9v)0(&g*Dbxa6%Lx)X#Rj~|iHcp_aXG;? zmN}YH#Dogjl0L8kK4iv~R&FfX`amMJW*xk0b5^^O6y+;ZQ&CIqV)^-+BnK%=NwExU z23*&6h(RAUdcRl>i%**}xkzxS9>J5&H+Na6rh--ApPNWf; zIAc&jlRpULn$c!1_la|^j4j|lMS#^Vkv2V$gwkD8j3iew;&g^f2qwsQgckLxT(&a- zARWaO$TnE0KKciwzX2J>LUV>ZjKEs~f=CQ{SZNmIcd4ueIW|)YQqBm3Q2JMJu&_CA z#KmPjnYhz7$NFGxYi{dfq0(~|+_*tgGs%zVETfi2 zl2vr6#8Q?Bd#-}Ke^)<$>vMi!M*wo4VmN$qlreO086QgrQR9(+#!`jC1CRV_c=QYS zRb^D%J5j|t2ur+!`oeI#WOdhzD!8TgFAww)Jog{`149bG6usFSbKm&89LxlIY3J&x%1k_90>nU#zC;?z=798(y4fe|7?Gj1_Un=OD ztC^+<>_sl{V(-9zVh((E*o`nLao1_3p8WK;v@7PBIOAGHF@TvAtiF@>_2?So~9&7?yJ+Awxl zhZK)9y`k|DDhhR5589_VB3u*%dn^c|$Tv$Kh$Kq+g+r~{O*^+i^`5kKw23j=|WQf zmSr8(1cn-7tUsx7B)e-KbOYiC{f8y;=gpzz{de#ghzpqDP^hxhGP4d>kn`R)fLDH8 z#T7vnN*Ij3Gpf&(p8AG(iJhEg8!Lfnnm$rS#69lZJra1K8#Mz6>Po;we!{#Jc@>k% z*Ah6;@N>HR4mq95NkWN_M4d?$`6OR)dflxW?GlQT5QeIm`9DYV2U{()y`vd61yxlCW{!4~ zIm^*6DO)Qtm1>!>6Gc=hbjr5ju4S4l$wU-#Jk7z8SE3exnq;zEx({&EDHNGXsBU7! z*86+qIfNpFY5vI6)1*~Jl$`|A_i(6Sc5;M*bpjScc5SQ0!`;czW9>djM^MiiylJ*2 zlMxg#G_34q@zv1%L3Tc>WPe>GDE?*nXOcIZ`mi&4R{_2GL+z@!s^uZQ3M8Q=tOu*{ z!aY|W{v(lQQwW)*RzJZbt0YtcN&*?06iq_e0hUO5Y~OYIvJsDjbnm3Nnf5RbtVG0b z@@RIiKYCs8ON90q8kad%69qaWS*rH#TctQeRZytyZ~ak9Z&{HT|^t7f*=8-IG$4;WQ42%&?wc6Jq;wB$I1fE!_oeR4L-T}76Q0ex|1y&=U zny^!de)m)v$1amWq)9AI7e`)H!3~W0id=9taZP>D=ko#aXJnUtfij_8b0ZFzyQF@( za)^A&r>l&7{FrNa2e`%QA5^y|eM6&OtdRAnULgS>Xncylq!_vJpR6xWs4#Ecn5bcS zZ$$X%SgHpdonqs;@dj^Fdu6NE1JOE^#wtOy8%w`DkHLKXt#@7sJNoX_V6!}*&h48b z_EkdrX=uz_3Dx%c;zx{0iTub5 z>o+YuWH;gDQDwpjZRO~5c;ylr*1V>tH@w=^L>DY4D=RB#cc%~sSkP+%0MfOQy6#uY_pY(sB^o=6^Lz{Et$&*!m z#9&4!;xpm7;dX+7jfi~5*hmQw#8pP}Bocp@pwUS#rCLMh66yecE~#QZ?RAQ-wI8l) z;sBVHdsa@O+h5HN0xHe;R@YqCJBh9{zV`G~RB=V`Sc)P`7URIwC8N(j^P(At#m?oE zv~t9m=8u>|xnwce9B;}-Nzu)TvEigP*EGADT*2p?qxY!JA^)Y}TFYRnjj&FGQCfr` z_fx2v#wX0%T`Hj}B;%yYzH`FtmKtNId9wnY_NS;qaRYX*n5 z-7-ENe6{f=j-x3lZ(^uvnUuq6iCWka~7_6v*XfT2!L4yF_fGm}j!v%Zw?SyjA_X0a?uFuI(1C6Znw`eR9- zP2EESD$&MW4os>N5x4-MFXPWl5bOV=M?5C=M%Z#Ytt73tcSwMXGvZNuvZ z_4mB)TOfzPK(x&!nJ0^o%-MeZHzmseF4G)6tbeJ-?DG{01)KWP>M`VU;OYD=>(uz{ z$9xSth`tB1YR+DGZw<+yP0GrnZAqfi?QP(OxcbN@_xT)el_!1Rxd z;9ZI+N*%yTtZ*nj5L}+s^BauurMOJU>gjmQ)jpmCzk6??N>g5?ylJbG9Rp;BJ7gy5 zdkPA;sWF65IY_|!X(YhM}?3> zoc!1%ATa!+&x=a7Kj@H*h)LZaZJ3TK+JXB9Q{~ch$>z~>p)P1iT3F9F-)vFg zs92uLQ8@+7S9!yptMbMFHw)%FjWB?5xe;0}=Kzqoh=;r<_vk{4y0DgeNjKN)qcWrq zE_q_CvL=||%ChnQsTqXXk@!&tf=_v;#SlVq!Ase*4N@Xe9U^677;ORC8{v!rCgq0q z&VY*YCW45x+O?%DKYOv3bvZMGWD|swJ$oc(ZF|EWm%7+eVxmjkCwLM+!6l#5gh1sB zvrCSW16o}I!3^0DO>NkmP8^_i%;cl#NikOGsLsTr?wP1!qBe5Q#54SZ=wO^15uYPJ ztDo{uuwRHPT1sX;Lfm2~=fs2u^W_D09Lcg-YxEjv%j7R>IfrpJkq%Hv!=l`H6I^7s zH|R0I^};YSee4drZN4j53W2(DQM#2JN)v@6uC`}rT-RdgpS}-sGXpZ=nHvdDniGQQ zPV8IswQ;$(cU4`|lIArz-WIf&U0<*hFq^eZEeFO*hNoF=+dP(Rw&EKc^3}owDaaLY zMM@aQR-p|YcT3yh+-Z^1-5@K>dZ;kPP&TX~-{y1E^%=Hv+?cuar(Q^n#p`>BhKeS6CN&@rM9{58FwKGwE

xi$0ozvnJnH_I#n3 z!s6nyNH_jW^$W%<-)8{0^2|FRw>KW_)n--=1EY<_wiVs)m?hTEX?2qa)1vWw?AN`8 z$u3AkLgxv0xD?J!*L&YzoSaLOfV+>jZ!28Scaz}!M>^Y@1ageq+Rgyr{>y@Hja6&8%iPwEqE^Ho(7mjUd*IkMcwlDI*Lg+NQn2=xn{^JQY(s8jqA#tZ=9v0;qeef#y}kx^ zxWXSpK#JYm4WW0&%55GLIw6G-j5#>R8(^{!F!sem>&mL-k$ZTx-J?h4;rrMUx+ta^ zCaNknwvi8OVua?q?;augQ}uvP@9_;e^P+^HhFmwfF*9NtpdxK;Ba+y9@L|T6^L9e& zc&ISFjKI!dC%@Sy+u|3b=qT4}uA3%-wPo*D6k8X6&91wfwX$c>^miK?H=8MYfsD_b zf8j0-Z5PXRym{+8jDhBZz`o7>N$idHg6DG&c(O=;fi`l`}8xSagIsDsbKD;`4~9CnK3sdn|f ziaNeo#=b#*T;A@zJpVZca9t!lIdoa|`@Gd3o#&t%4%KDmGb2!PnEXV)UkvuijfXI!{Ljqy%gkdTV(#h)5Dmx1EQ%l!QX=H*O_EJxK< zSdZqj9xNL4Kj5qUfAF=DHD1pnX}Q&k^FR1%4Z`vMo8I#d*Uzc%EWus||M7?DT!nCt zTm$d>Ck8F7e}nw}qZedAe@x)d3Cs6Yqs|X@$COqCEYFDxu9)2;3-7WNRK5-i_Q5gd zV}s!C8#&%GA20W9A`9@7uIJBelP)qBOSXtLdQZ}m>5wW(H!cBkJutq^aVtqOCy^L}cZCJw`3P0i@438SAgx(!azJLN@lT8_QNJDe}kLW8|LaO(m zFK4r^(Zt~@mc%N!nTuXMDcIJutqu_3g#ZPL$?F1s3?BvY3fOzGgrjk=nSJAXOK80; zy@~YwkQefGoH%R=)H^4{7J8wmf7duuL0s@>0tr3!5NQUFuGxXS;Cs9U4+)?j3Cpzi-hM;v{2}#|j43%M-7s;QdlFasy#hpS` zI14mwSL`V9hKD4Z(G3xOEY&j}QpO_z2j3L0#N4LW$e z**55;ZFG^aD7U?n360JIf~N3c@=Er8t+B}rV`Gb%h8fDTdR9Dzi!a>di;-ZMjtEej z){^ArRlY42AoMOh?l|J2Rv87Zz7jYVO~bLJh^38$fIuFiM>L%RWGt{ug4c4p+IE8% z{Z5yNIR}TR5;jO9pKwGr>oSiCip0ZXg*an&1zuo_8x9V-TnJ{CZTZF{ z7W(W{m_Rx5HIqRRVJse6yZUJoeU^_kb1@=<_8(jUqHp?@^432q)`Y! z_D{$IW~qe`cS~+SX!8+zWr3wt)>0~{kiJp~(Umhp`}o^vuOagxke3o>xO#UJ2Lv?k zJ95>h^Qwi*4ByI@_~|TgryeUo&CvsGPOLMW0Y)yQ2=(!>pvnYSLgrx63Ho!y7z4pnG5A<-CJ5jcX3T;$b(miVN{J^V|iGIwU4 zh?vM}H-h8T8e{y4>SiV<9}{W4Nge%B|509W&T3I_Lf$`uS`t?mktJ0-qHaNw)wX=8 zwa?&(7nKcF<4T=c$^<6s)#lbgoN=p(vVv< zFm9n~ProcPF5~?7&peC@INgSe+r2@3gaAgw=TnjOerEMD0SSJ& zO74j`EY1JL);mRK(gxhNv2EM7*|9seZ6|MR+qOHlZQHi(j!u6^WA8ow`?{$bbx}3v zTI*pBg#L_v#uX|@7(7`bPCL{w0{yK}P;41wQV)hFTt7&IvoFd+r#}O&1%-xdRxk@T z5b^<)pPUY=0Sad&R>i;fK~wJ#+H9lrR`BYAq*P3VH_UfOsLMm!AD$6BhsFU^_=E@s zN3+Sz$7xPa4YDDv4By4m$<6zNjUMNjuXiT-z!3rD9|>9mo8B7<>og<*_Tp)ZzFsC` zSMkS*j8%o-suV48-&^|NV|#hs=N7N)+8D?eMK)dMlLbp>JE8vA;CW`zo5Iy-RCs_u z_LFcg4+df)E1L$i3kl@w74@@TK4+wc_I^=!coxk8@oWoG!z*BjSPMDJ9hu-oUyCVJ zs9P=;akp3STWEm#F@?aVa3Hho)iLKbnVrhUA(=>l*1o5adk@*aT6S(;p}Nmk+&-3R zH~=j?7PS&ZnrQZ@Z0CA9Y)iI}PX}`#gX)L;mxOBYO_=@)#Zomz@~9hk0pcXIaDF#_ zjT9C6TN+rU%BH3|ehiif8!ROHSA)k8X&kz&(N$yEFoRHLU~{ZILs(Z-1_$#|DXjYy zu~||PlxwJ~KEU~xS_pZ;Jf`jD%*E8=xU23+GWS!sM|;CJ15?T=!}ZvBF-!z;<%LHs ztAU*+*`h6ntawrgiR3RGbqY%Gez<5;UB;Q;P+bw9Oxo%RmJcrA&IAN{SYZ)im|M*9 zgg#W3tW)uAO;uEiqPS1y@?bhG|CsE+z$lpyZ|ZSfA#4O%mdQUR`}qGbS&68>l+1}# zs(#8PT4f30Jj2SXs?x4sM2ktq1l4oHRrOh`Ipkm;mCI1SOca$PePn{URBO?{Cby7S z>Qj}H$sT!x7&OpQaJtk~z0}zqr${4}&g;?#*jwfBN-hR`^MWH;_GM!xm-&}pm2}nU zyh9jjEBeyusPQdI8;6T&#wkVJ$hg~Qr2{P&>%mhXwS`S#X${Y09TfNN_XUH_{C+s1 zeh}#h<4Nz3Zyu7z$nMFk>&nu*jWiLXu|5g8-E?dEXo+P43R#CJhcq&~> zCm>9c(PRsZxEbaGrb0aaTXO(rDAl|`7TM{n-^SZ}=@FEQfMs_7$m6JK(Wb2k%h&K1 zk=%GcCHQ2tx|Z6;*_*qQqsPi^z-Ax4GbD>#Q+gd3GWb7BGf!g(aFA2@L$j+U3WDgW z{3Y29QR&4UwWWZm?5CE;Pt$Z3#|?qR7RrlLZ$8vNA|e1*8DD2dPmA&^7o2+D@t{7N zribtrOniA@OIJwn?rcfo(k&9=MCRF8Q00`EmDF80z6Yo}pd9dfPXcE?=7Z z8iP0_`6ejiYj_~sp^3ASBJ`RaRZrM2;@ngt5+>yxz~F_^gmw-F)tYnta;~Iy@@drz zQdAV}1mbYVJ8{HJT4QCW-f4bJiYH55mGW%r2Y>R&-y&P?{ev%yiI-n4-&BjqAw}^D z_}Oiqg5Lg7Y&74zsk z%NCQn{6Fh5G%{0;{$pbyWN1$H4P8jD*S6%UJFX4lik9VRA(VOOTb%iq!-XqND?N9HBcxA7DnvEhl6`mV@vl+;c*mER=oB&Z& zX)s$ncA*HJPJAiJ0y>LO8~E=D)uV!qa-oIuTg?d~ z`Dp~1ujm-ahK)O^`QC@#CoC<}A-p5E{n!i&v4woDK*(X$56Gjj+7#LSvApLit6BZZ zvJVRTZvCho+*u#q-tEjWO<-SU)1e-Y#`~bHQYgoel%V~P-Yf1H8kNY)satcF&uf#( zTIEy58Qlq|+-d<0C1n1<{P3~8`4ZI6LFWMu*3r?~ZLLq*`5}BWXSxc)(fz+^v)Igk zw3&->!GIRjc76@>=U3mJ?K52S1UgDt^0WK{tMje}r6Prg@MNj;lhY2As?f&Nd1Q9L zhHT23782D2$)@AeFk*h{*wGw6A0Gu4vn`aQtuG-0j3(<}gL2EYSO9{@1X<GF0TRJ)+ops>?UWDKv>-Udb60;Tx7nJ$3mTa3=4TVJ=iT)(H z)zMkxE`U{ae3^#NJf19kxtF9ShD_<;02B)AKj8eE3hY1NT&XkO^Yhd~3rn&)h<5@q zQ}n+8X969Q9U1N}s(-+_SL5B;$;M;5$cOSe>8Z<*eE&N&*gh>@*G*7xN}YYBfifw{ z%{n$MC$BOW%e$wiJxtw@9jXJ5;Io5Jp|{3MSbrLy4M# z32pHm7I-gzjJCPJE2FRD(6}jx7kyLdXgOmuZ;d-wld6A{vb-GFq5Sa-T)~RFAtLPa|^c?>56b9k|~&1J?oWOEFbX$ zZ8*`gc~Q%lR;fkMMok$mRLb8ok0#)fR=H(S> zM%EkRiY4zmqjqR~E|-T{pAv|-{JMgu2rUmD2e?Jr7_d&F-F@Shr>hb&oTT-1Q8QhKC-g2UWj&bE z8G->W@NKt^^lJ8JrC#x8UD?WGF`)BmAPVJm@ca%hxI;3RtK{^PG2Fmf=Mh7cXc)dG zlv*jm7OmseiH(?lNIKm9J2vYoDj59{l+#^?t-lNA)D_({M$op_n$)yad3A^S2B?OD zI&3_{4bi@lFUFAp$JTh=EU;Ad(XG%zKGYZm2VbA7@%%`(l2zp3Y{33*_1e zFh0TwpYM_uL)2d^?xr+r9G|(H*ZQQ8TL;d~^nyJkYC3aHrziFb>>kMom7;svI5uo? zy+RP^rrXAHpBA%dF}o^>wA@K!st$)Io|hY=a9%_B^&e#R(&dFN^|Wvf$9qKYZOflW*Qnya$wCbXfhW`zoRCfipEDk_ERjhtP!nhta=l5{o-T&#rmgju@UfJf(oaAu6i z_%AJ!Vo~Oclnt;^?f|*qvqB^hEq#Wdp75h~_Q|1I+tmTDs#=`jqcp#e!mnu?awvD9 zVc>_@E<{}$E-j*B9o8D^_uF^?w8x$&kz{}UKGlUY+Z>2eTpWnRwQhSxOJDb_Q-CQk zC+ti9z9cS)kdzzRh2plY>X;AJ(eKYN`cnP9LgK{9@q3k>A&aT&MahbvzClV{1F^pA z9Tug5@q82wN6pe%zLszzCN<+}dK(3u$zErz;=mtCelafpFrCAkQFQ+E7`9fxW1H{b z5@>}EoY`{D8ffdEVak@x(ci5rqRx~b*M=#Q!j6-2;OLXEzR!9xg#=jL&_@TA&s!6> zWF@SZDk75GXyuJGndwC)yjU5qq~jZI0NonmiBIcs)_+yWvL3sS=s(I1kr6D%pHY}3 zso6jl_@>%N`}FD?*T0ZW;nKU@b5Cz{8gW!!ArVij_7&6f3afb48sdd;_#icwnAp#) z@;ov{g!*=hPPN4Af|O?slfO8WnEBa!q-0>fws>^9L}0d)l=#-7byYR3%NY7c&}Z z5o`Y{s+^NMxo4sJPk3RUEsQfwM{x$|&cY3l!Qph>4RoCvagJFUFUN2k{e_w78Z12d zE=KlZoid9~11&1+lk2!gA##0&8i8JFx;1E#?P5RUF@vKJF8^SFYP>dtY_l|)hUeJp zfSI<@U1Ka+XjU-L0=+aUh|!RPs3Ug6(R3e#@0c0*$MtFVtE9;69rkMMvpEbsg2dK3 zw9Fc#>%|K_9^KhY^vN{Rr+2pK6KXwD2JKu5uMm^{kxgSfV{&QwMNZd9sM)1vd$D#mEb7^^gs=yKS3$q~et{2+BR(d$4$( zD5k|)oz;6xs*W>|O`oEFEz#KsvuW_R1zMUuh)J*}5?2QFQmpZaeU?JLWsW+d_HYhXo~&#LfmUb5 zPyKl!ph6x55iOL-=^6KSas7vI%Db`T!1PgB{~5so2yF?&3?t99Hwx=m_Lw2`t4piV zcj{F+Ns6jeq2wy8)zJr)SXcHIlM=5uF++L5)q%Z9z0b%<)!9J6<+{Zo6^BUv2?-ms z7yXcxeRB-k(qHI_8SMWl0`tveK-*Q`1td z-9LZNiaR%Xukl}|$5B})PBJof^-fQ`d02P7pUf`D2g_uU;m7Kg`AVk_iw5d0C)}b+V^Rqdb_$-?#UlE^vOj45;3@v}GH# zl`+&;4~?J@p?BWE;C=b=%^!_;gbh}e-^$rW?_#*$B}R47>>r^O#CmvevN;4l7AF_& z*p6qvU7noGds{!&^8`MWYX#48ubSOE^S;Kh9^22?xk&;|1!x=U!`%6nDZ1VMI-MTf z9p|s!j_j_=mKpwq7cDVFz&U9%l=p&^xEod2-a(wbThx0!DmJ`3WdyTXMl|$#>VQN# zR>x{F?0~BKuyR-suu4z*-iMBMfi&P{tfsBIFyfdp^!qVy z1a~P$B(@TCQNSAg&R@A)onFDH4i*SxvSRf7nt2&d>UbrR4a*IA{$tDDa$zk*u!X*J zFKzJ`%~tNt1gA!T(F;Ji);8Vj>Tjr3mn#9PvHBv=Q~cp0QM@%d(haY_wf_vTh%24) zfuumGs^02`Ql=2|@%_0A+p+WVdw&$IclXVN%F4ZY;iW~OeE?N91zBCE!;O1Hx7o9R z$L0DvSPv|OUXx(=bVkW>7XiOzythk_+Xl-Z`g55vGLKT~*s)9C;tra6uiV?4hlF)@ znE4KkB?9@g81mB^q1~qwEAId%RW_J}*=MlVd+Y9CDRK9_5yV3r zWWkMR8UG|z`b;`?uG;@uhSL*GsF7d0*E`N$D%M{z%*clwBgiEg*_HQoPC91T)bYAk zYf1cX-pt`mzto5Vz*Q5klm3fkl_s1-rnD<*^ zynUv*T%#BCoWX6@+pEHQSGK%A$o}g#g?DE!V3mpY&R#gKON&jm(^5Xu%$zxoa|#wv z5>e;YSm_;VfACunbnpDA(2|2wOChrqe&Fw$8%y^9cqXR0M-!2H)O{BKwnLI*Hfb_` zT1Yd)v{9Qiu$7YBx64k`vsegkx^$3_u>Wsr8|K?DuU8-hC?hksvZP1vRE0gh)we@N zErkm?Z!jwAUS>fBbNjv4JY1;DW9q3ceo#~Brs@^5K|bL6eG=R-?;zH0Dc6L@Lv!m3dwbyac^rUbbXpBZC!gV!1*_)xkGeAeRknP z16STDDN*o!x_e6ld!PnKkXXhJ)r!mAS>5tj1P=so&Z`2x1lZ9d-38xQzibc7m23XdTnz<++I{tibX# zQZb;$)tnFr%ifs}zn$Nzpe3*O(H+TsDNx!jr35pjTdm-BaZXN8M`vdJGrqSoR5N)# z+zu{@7#yUnHF#$kJ2BB+9@(u8g-5Ctp{XsB4%&}6wxcOfPaq4}==2Z{prn?%Nc_-^ zoYbYTYQb6GHV2H9ji83d+<{;L1`AmOOeRi#9|MmBCXXqS4zh(tOl5S8TfGR z!g&36F#}0@zJ&89m^UI#x4p^I7D-${=B5u`WoADZIMEbXT~WTR)d3%3v4T4+t55L6 z1%u+)y9H||01y~8x)f=)6U;m49o95hIX9qsrm(mrKAML)_%6Md%x%Em!Amqc556cc_~FT|H|jomk%g{74{7Y!ppu}o z2ug6cd7Mtd^e@WGVb)ie9)8v4fC&FZd=0p(F?B{oqW1?R%$k%wO1A4v+kPgYH+HeY zxLvWkS55t`eNAsBNauyOI-N$9SMYE?6j1J2eWRu5USCj*@;l){VbvmlT7P)h?j{ws zJ>YJM48k@;1q<~C#Zr#FfAEj(h(E_pE#A=Y0^ z)#4R(5U5)7_WgMBduM+_GPXHIG!CDU_87#zT)_^93|WVL$0Gfe}ihKP)c{R#RJ==SaXg3Y= zWF}U2?iq8v%hpaA=L^~9;8rPg2Mgkv^G2m_ePlnVYoUJ8YXj&AlMMn$*DC))WR;V{ zfGG`|n!y7UHMdlK1@q#oOtAmrz2*n@u3=u_f4Jhy!U@u z)}*9FI2eW-<&&J+O6&9&xbjaB?kiIc+-)M<;bo1f^i9F}A|mYz<1dldw=>6JcBB^o z+-gX930zS#%*dX}EdvvW`e3*^BlO|D6PAMyeqL2r0Y>sAH|vFsTfI=Hd4*@Gvqe*j zC#6k(15JHx4XXs5qA1RcBcqhPxsQ5_#rQHay0f-(H@m$6a6J7rz&@)p zMOU&ijC}C!I+_Yis{quh@T088VxMUj> zv`*Apjs)dd2g)z*HpYUgdQ#$?I-!=>-&;%FU)i<)7MePuDhgpP4ft*QhLuVJ`s_j` zEiBDqzGwm&9IOI}s!=Nr*IcdvZe2Dh=(7Y0UHX-kyJQ&C$!knv`8fGfW7-fo1w~_Q z$65<=3#GX;>?ZA*M2bdGS5cxts^h9HRIcB+k}+wb|>`B z9{s+qt?p^FH8hApdk1*)$&N}`Q9u=Pqf1Xud6E}U<00#;o*c0-+D9dWTBU`X@QV&U z@$8$lS!ZPaMw=36v%u1OjtLijnD!HigNdt$?d?5c)`3v9A;n7&qXG1RunN3;W-9IO_Cb3LI4wXh{bw=*W zT(GGvCq`Dn!^Ywl;UjJ&VbhWv(ODl3ra@|F`)Pmt#k|c8a#|kqhcYDG``Z^DE>@C+Uzc(#w4zA16bvHmn)q`QfvMRz&gIl#|xWtd|g9@-P) z&%f$kx9M~B*BU}X<&mflSJ4vt?T&!5mnDukrqHv-ALs5>)SiLN0TBP{` z?I{+sBCOP?MEgDlnW3DB4x&|DPwz5b*I76mOa?u?>;LkWI^CNb**@Q~5cU+%v*Jc0zuLy_K!Og!}w`HCNoCU~kTR775JV1snD$_IRR@0`uQ zi|T0_4gpa9M{S;c=9r&`z+1bNr}C>UY&!ePUU z51v;aUR1gPBj{1oeTW9Y4yAX=V_MWdLA5#wK+^*z-oD&XHq^c zA#;Qo9n5^sA}OaD9_u(wOxSmEaN~?H%k?*jMx{6{iN^)$U!IFEjZ2~;ewrQmQ=Cv- z0hf(yH>w2~g3TPg-HWR`XIy7Pgn6tPvl(aZqs`Fa>7nG!AgwZCP((>&Fz!8^LvbLN ztP*jAet!{rR7^5yUU0iIGs7G{-eXl1pkw;80QKqgYvgLTgscwrjHPUXy1Qs4SzMyhn7TD(qf33DA6EyB^{l+BI~pbAeo zl@x6ZL))U}qvp3EkFc!%=C7>vKy_`R$!o5Km@U)_8~p5Zqn^Go_@O`j%CDMXRNom+ zhuI6Wi3E14%C^|Rk(Xgw9pku9U(ryP-3z=&7vS4Ng$Asy+r&mlyMu%e3{JAVf@<$i zO=y(Y%8lATzLC*~j1^!Cd9Sw7q*Wy8Jd7uY=s-ZBTcA!YYrUBTDtivT)eTIK0*bl= zvV(>{)uIcsCs<|_iD~v}+vIbA*H!$4T1~dw8Hzitg4e@X4B%* z*{MMaSSAkHi)<#Se0Ze=Gg4ce;%n95oVx5tMk@{dx=~sR{o;iLEl2dYS2$@$4s?`x zG2>ePa%W?u-C>$Y>lQt4{A=wM`Ed^(Ve0g z%uzHC__*H%?{;Ng&gwG3tXQ0dJVih^abv z#iFEfTc~P~OlTc?J2AIrl+h`)0Y;YaP+y_>@-e2o2wD7KOs4M2`Z#|1kDDO~c`#>T zJrpSu{R9^xP;zg1k?;9Vz9nLZ{Ck>2ywU;vg5 zSSb{7I(h{q2zwyth;Uzop#s>^ZRtV}FU;7qoD+hTCAo<%Rcb>Cf1F z?(o872;V^P6@B4wGHfhOBfu9&S0ymPZX#o1fp_MyKy2~q(F~Aj$qzik#Ryk;ppI@w zSRR)&e^U|ds72k>&c)Ok5pid z^%mv@#7T?8AY3n|%pvIq@4_ubkDsgVI3uM}@tb<8c6_9f54Qju>_+aEL--28Kq_n7 zSgUF~&;7MC6yoX6^V+*Ohk;vFs*|u6h9Mv>+L6ui$)_JH*6&*TMm0xltjJLO9Sk3o zVCF{J(R}z`;a-fW{{dVuV+L1TaS9ayMi3jBJFp=XNk^vqM!c|z#R*V^a8V7}X~r(o zi!BM+k$#%3DkSR|`C^()(2*ixVH<*8XM;J66ngn3$S1!zwOj{#fXi65%dyuqj!7c;{W&ev}(b|Bb8{ZvJi3b0I~d8Db*u{ zyadUc>*(h(nsui@em|vEDtu|+YZMoc&#|j~>C{`yfWF5@%ds+`Gu_bq-EkjYBA8V;Y}%SUulh-m)DnZ!dYY46n?h?seVzD@FL;b*Rhgda3Enqa3kc!DaI_t(2h*Y z#0X|>T_6UA)nIAs`}lB57kSt0+Ji>pU|kDmRj|wXG5=Qh$O?&R_qezLy7MK__Lnkn zr@Qg+H9;Vw)@J<*$9OV7VoxGfhhf^m5znp2R@ z8HfgK#I+IY@Psl7K!>O`&6MKG9kWato3_E-1W4;&H?%)a8a@c5zlPYHDEN{kBoPvx z^Q`Y%O}?%ButB8bYFO>zE&3wKgk66Z|CX0q1Tr8t+`&^&V4uk(z{@Qh1KJ(tEc3&8 zP6bJr7uz0_2%q&c0LM>$5*2BDC_s!%$!Mo<7p7o)km#nap$!ZfRN@3~8Yw%+*XW>_ z_w|Hp~_uk zdRoSK29s_02VIt1poo!$3FAjr; zNjI$dk}CnfA9It6kz^jbl|mgMEo~Ok2|1+LaPCM)IzikRHtgGIr6zjwjTfy0&wie3 zB8Id1WYgX-!enMyM}SQ|Qk6z6NYN%Ir$9ii0Ac1mC#dg|H2Nmz?s zbsW}T%8%8cvTiLxIU9|;6Cpd>XAIy@N1CDkvi|n>?&859cz+s<`=h17wbrNXUYab? zcRzqa5C8_6c($~Vxz%fFaHhpTVH1!;AvQ^K^K^jhOvD>0bKW_4X&GMzu7wEdXEJoE za!KJEHVzi^Z%-E>M^YG+W=kiD(ks0M2gPYAJy`ujN_)0$Pv9~o@;JQ_#(5rD5XPBC z2aR(`6MF-8JrD=a(ytYq6P8t3ABvx?$4Dh%|HFnXDrU2Hv~KBC-aUwlW^C1M%Y*OA z`9hJCsz>+ddEs)eINe%ZhCV6sbQnSLJ(e}IN!rZG zr3dm@7&?id!UmvIBZqLO_UGnz5Z_)YWFjCdArGWH*#DJs3|41aVw`3@ZKwY_CH=Mj zy``S;G8e^uas9ebcCApXv6l0RtuxhRG6> zKKjZbM$bsrI299@S$615^g>$WOP@C>hZlI9>=>l zZIh!Fp>|=^a0hb=kso|>*AefeH@`!-%(W}C>g`9r_-MSYPnaN6nS^NGP8Owp#h*}H z$cydRmglNTq-m`6_(vLk1{NY)N4^Ef#mw`5s2?GkJx%QoWw|=fnmsW?@Z>3_m4r4D=fzm{v}}Bq6D5WM$avw|S}vsR82p z_`#W>r-Wb25dG^+TB=OZ5@giR@7s}k4b+uc>)xfb&`%FKB|6>9Ic5r{3R--wfhST> zS#RPiO4G`@Av<#EHrVDjR)@6m-1J$VY)r&8iJ_-YNnS&`dx`p)7beN+qo9YtkRr&J z^seyYvnJI3kAb+bwZVmhqD?6`Rk$Lhj2t_papHc4znWzym)ZXDuK>m+=E2p0R#~=* zh1M>0*|(Jjbv=5Y;}kFOM?NNLFuzUyE5wcNZ)#K!bk|HUUF0IPAG4*XvV(9)qHKRD zF;Sgv@6(D!*h{#co^1JwvkDB^j;ZqGe)LiTtIrWSN#kN72|COEcB3`vBFmS0um|h> zzM|DE_(dCz`&LY-23acCJVek#mTh)oSFjFdV6@xGZuug@>`7v+^FeI*4 z`cM?|HgNlbV@DEp3_U{!ToFL9a#EZve;zA>Oj{zJ+{EyGQkw<_&M~XDJUI)GHE|9H zeDmU-r^{brDv`~TpFO9CySCi8XLViuk7dyB=}%pm=5}Y06Mk~ZK$@y}vp&15-Y?9l8~YzqYiW(3=Bt9< zYzd~P!Ij!OHI7byaIdf0BFJ7EI!%Ifn!rrcBv@H+F*kfQislsVHTO}7dD*Zij?cz& zY`LIYn_3g_W|u(XwRjC_4dx6)RsEE^H+*%@BCNPcp}x9-{1-sMlypr3KBh;q%xvcC z`=eLs$)jG-xIGd1P&jFOeR&suRfAUHqoj zghZudGzm;GSxkc}YKb&0+Zpbzlo6}GpF+&AGy%Yhj~e5)qD(lOZHIWLp*+jsxKT5>hNBPo67=8E>r-JdVxZFp;RaKXONE1pj%Pk?Ly2~C1)10`sL(d z`MX@Pluw#wDmmnAxLM-b;w#ZK^2?>TwaMsm`h;e48sUQugueXPQn*?JR;iUTV|K)f z(m`)_rbzAi0j6f9w1m9s4{4J>yOGVhZ&m2P3w&~C$sA$>T2l={7AkC7TM2zdA8kjR zL__oPqpZUxrm_N(i}l_kM3*oF5KQ-QvT4gHCl}Dl`cq15_Si+(z6^anNnND1<6UIn z=2JzCb&yLLO5>jQ6!>eAoRg@uw>;qQvY(JD{O>rbK?YKwtFt{wJbmsVu3@W9 zTkXdHFa+!*=bP*A?mzEYqxvr`JPGhxNy>5j&JMl;uVuoTRV;`@JtA!%9}2v)B6GW4 zAAf*8Q-|&V*v#S4rXkf~ld?D#1l}sa3Bx3DZN>F>*>r}F1m>l!Z#6)~6K-$DB^T{} zm|$1gD2g`r^tjYR3!zOA5k9WPluv#&@2jl31hYZ^^1x1dA*auE!L+OONgl|=XLhkn zyzgmZz;6Z5#8@jkB=Y&_XG8Bj>Y&e{UY4S7Z7ycYK)~i9; zvu4_(%NRLS-0+V3jgjl-jz&_rzV^~*=VL|59mfU(Qk8kl58`s8Uf!)_G@qZ~4i=5M zt9Zp(pnUc!=4jt8!g5MeASZ?xK=X+swP={m_(*3A?UPJOVEpbqy8yp95Vhkx*>nx0 z*$f#k(86W%;!J`$B+P)Dqn)bpFSO^zpTv?01eP?c_@XG^lq}{*h4vwZ`0@dFra-+K z>_dS@<}EA+*&ts5i@%wHq$u{L{^HQb$n$XI^c>Vmt?Y?`LUmcd^ZuE@1sO^-Bzu0w zi599mu%Vq8g5Vd&B-`OygqA0CZn0dLZ$~3%kDll$%U^3u{gvX;zge(Woh^O znXZDBw8hLOe>vcKx7@mKniw`WoQCwg3WuR#WxMTAF;TjjU%~2HH9Jbp&Ruy6YGHef z4?f+OnDzbF14Jk)!9!p>9$+>&8D<{~0_mh_oSWMpV^Gu9GaU z=z39_4OQijnsUhEwv=@R&t_1lZ9Q{UQH(Y@P=ks(Wya=Eu|E_L?#3U97Vz&b`A~Q^ z#^9K^x_DSRN#+qIwT55u3>caamvSwK4vB;GO18GYz-uj1#}{OZomOq9HytPbv`iF_ zq$2h@TD$7bc`th-PHNlOWc3NBK<#k-9%yac-kn-`A2Vw~@Y|8fTCd{!gb_2uiXK?n z$k~}xz9nI`pufy-mc0}Lvqs&JNf0EKIq{?~uTbs_u|a22GH9xE+7N^~i-xPy$e!Fi zb#biWC#D?^%jAjz$Q0A}<9$08V}N3D#)zC{LcwJhle}bCdec5<+cf1n(>1(0>HMw`=I^Ng zsv+hTrtLAO8gxol=B$p#^jwiZdBs6SO!TDU*#@Kh6LCfBN6K{U>)P2lBsU z!`dXTH2wp?(i@%su{M5VY(Pfu06vV`WK4MoOD)ka35w*w_&3|`3-cQ zUNn5oQ}KY|m-MH!xfi^1iaF|L(I9vQZjC}#Brx$wTh*WfQxkpNk;nbNK&*;gk$u}0 zetYbneiHBZQr*aXBn_I)#~gsfgkWBeZrkF&Zk=LA;5?91C8rjA^H$5hfjQUrE$y;y z!oTeGL38HMRE-%mARS;hBwDjb&`s^R_ zlsdna{xGXv_v-9S#IZhi_xbh&>7Ak<3fZSP0ueGQqj_Y+%vKO3q%}s8Gqy5^AtPV4 zKkt%-(aH^BZoPxAw2*18HfAkmd!mE)1ZL&xUPGGrI6GBxREqfaPVwwf8(knYeuG*A zP+uYON^(PN-7_JeL|Cf~c~)3R?q7z?k{D5)nB~efp^2d5x=bJbh%I^3sf662*~R0F zlUkV=^21M}`=>T)v?^g-s!4yEFRSeO-t}FS1k9XIUd&|X)>W&)Rpz9GF7s-rrj*cg z=DDe5D%`qlqAL zUWwe4gwB8*9A~WDwOF2>VHnEw3au(0tNKEB9;2Fzx42N>@YqKY7ZO2HBteU`ne_&q zTzXiEcy3E@21S_JAuy?j@R(&NyG&Jr=ou}<5#P3?pCqqv^}t9$8iWv|c)xqGR1fR( z$77P$52am6a)3((``OIu@%D|hm*NQaN{5nr7vl<8_MBH`rt$vS6eDfdVANsMBU%dPfFXXvUuT(8MGBjOL&`Bg#KFHVKN#ym zG!6$v_ddVLaGajmgKfsM9-WG;w8O#o2FpyRuTfA$UE=ZbFHo;H z4w~Z_Go*L2RJZP$*z=dXX~r^4lXQ%R(l#=WUgF^%EZrQV{19GCq9(4=mvu};0rxoA z>4J|TbZ=ppg%^=A&h_iK-~K)ijUGnLI@`_#nn)-#)`b&`uX>@ml$iUxyT+;eDn%#w z(kgitYF+efQKU=e#^WMKoP9oCBEg`MZj#{KF1}&H2!M3TsQYx-xsj8}^n9$25~!X; z{-53}zvM^HTI(bs74W zzHviE|0(`?!&zp>DhVrM8l*ggf3zPc7=&+3ZMop{C6Zf>TRyny7&y6Q+UZ?_*ou<6 zpB%7GQ9K`ne{*=Wa^y<=%LMYcspzGfJPhU?VzbRIARf)EoRitju}l-u7CG(FemeMh zdFFbnu90-TQu~wty!w&fYLr(I!}y9vX*cWc#w2Olnr2_wTv+%sT~u6Y^Af6_bg>xs z`CE6qFg;Q#RUi!x$a59P!N*)>5w={+z|c(2VczuA1^t}kH>!qJ#GWRDW!|_ntpX(n z_X}w8c;=%epg;Ahi!RY!Xq{FIr{X1p$x~XI!~9OsHbJ_PthRFjNSheWEb4Qz+otLq z?+(iQMwKJRwmT&jn#IxF#9m{TMt^Ogo{=j&JYuK7GXO#UwulWKQIA?HDurxSC%^7mM0zxTg`!90jJ&t6$Vx0^zfCd?o{)# z|Niq(vckyoOD+pV8CIc3{j{k<7%iCb*YOSf(lj5=)=>T{8f{lMz~i z9+*g7p;UH}@oq&5cje1ywMgW-5kF0zU=(|6a@qkJ!YulYHr-}NVe$AiQ$jMDLcfOA z_kYoKPeGytjh3j}z1y~J+ugfu+qP}nwr$(CZQI6f-2Ts*m^pFh-p7i}$cKuGij1mn zt>iU$;dGE(JBL4xocq8)2v8=i@L}AwQ!Zu+ts6`<6A43EB`rdyGoPu2!c`~)KJr|>un?u7`Bqnb>#U4A*hn~AtXOULZ8a!>^j z3DnqQbtb*3dr9m5X0N7``oH^A%;TN zv3o;uGt6RywoH7+2!r&nF>E^X0sqWS86pvBlrl#-r@uh3fQ#0zondBHPM2;Q201?1 zL&M&!l=wg;1zvBqONvPJd2zzvav4{-_p*2SBXgxvaI(LAhBWwbJ8-#7*=6-wyK8|* zG(TUdFLMFrnoq0ka~pxF{VPD)#&!A5M0Kq%RPTaSc_yvgKi9tNF5_Y;8bUG{!#&i} zs3^^rH!iq3uT{3~PwRpepHy;hd6TQRG|vNa{1nPL}CJ5~xtBNih*~Msdwl3O6Qg0*7 zZlh8<;e47I*Yr3VDKZ<4?pjkB4qDS zu-e}?!*v|-EPx@jSTb8atZ62B^=^G;K9sDp1$S`afymL&L7oqV!Z@-|qkgF=ST9dT z2#>$lvG(6oP%9Jk-W{x0d3*Me1{&5H{*&5NM_TNpo+;0<)GX*n5CB1>d@=%-_o4|A zNRl@LWfwu$Np-^w2|b#J8WKu_HVvozZm2qX-%B}1ve80)cea2o*9mtQz`t`$nYAs0 zKLi0;&ZOsD6JeVR>+p5OW0W9GMrdxVh0E-G2NOZVTY)c z^w~@G(05#3o&HE==FoHCrhL?+@pIKv3W!xfNO+ ztiwx!wh2AtMxhW&o*^ccZ6%Cnk@nex2gb@bS)};FmVU6O=(`QB)o@KU*$awi8lb86 zp!ip;mw;K&0{yUt#{aw$z!s~DO2Lq{NQBNl|Z1aM5zqOpzYe?|c?r-b7btXU0S7bDi0YoPg4} zFnqD$9X~Xa*e`A2C26fDrU^s?3F z>Wwtg&Th(r22%b9krJTj7?bKKo)CJo*W_kZrVnZXjSh6j#BtE*)KS88DdxEbLUj&Y zcnWHVWR?TeN<~h_V08m3)uB<9#wz+&_K2A#=-7Ml{H9g+Ws@%#w^>%Ev-C{}e?NE^ zZ&~Prxco8CKZfDvZv`o33k6%$JJd3p<1}u!fhk%NC~@@*m8NjZB_j{MonekP}XOm zpaMs>?=(|gb)q=wsTT|vfS%y6`j`huCok2E(7+`BpY|`ZakmV$MdsNIlUKw%mMI^k zpKprH)G_b7|6kb;F8>1BHQ+%WcL2RRlS=Jri@ihhRz4<*pV$&J2%WtSMy*d zAU27gZQo*(PcCGJ4a0lN$AJnArM}z%n)!ucfYD|L-br;sz5fUD z)9;z0ndRl~rsbA4vfXXY9@TleLo(SG3L>akSpH(tz7}2h-7jtljrpv6*z9e|Ug0K_ zfc2M76)d^+rdm4bgy?8Ng7+}0<;M1YhzTd6D5XrI?YvsvIxx>PK?04Th5aN(nX)oC z<5stl_9foTGrN8fJ*$I% z2P+u+#R8-U?LgCz*Xns)o*rOzi1GOb>xPh48|a@yr@Di%d1rniHFlyHUpd6xHG0jH zqydfnl0O0nRJ&%Na6u`f8wVQ0MAq(!H(-+x!C099mU|WfdK;a$&FV0R<*m4+8(?jG zrV85Sm_hmGp4eIC3k;?9HvdKC*Q}(Xe^XtWZLopoOId@`dw7nlEE{pFdj||Gv>nUf z_lVvG&=9KmeA2d9p}pgl;7c)Sx*pVF4omuWf%usX>ibK~n<$EpC&P9ga-EeksDs5Htnz5sX#}$Mfq~YA6Y*P&-T6kD$@*4fa$6_u$5bxt$xO@K+ zu^lEm0A`D}oV9Jfkx`krn<8JWS>C9nKkMEySn|-jVltE8B-5lnoQ!yvc-7vkN_jLE z7b?7-IMOBMg8yyl@^ZZulgo6A(VpMdXBE&hZCRn6ryw=;EOrA7Y*owpgIas!_B4$G zz6mJ1M>&lM^8do{j(GnA!$Xu?YSY%#j)F!iY&`PR#OwzffC*~F-2>=Rs;VsvZ{Z1c z)OAL`6u1K{B!bMplN1EM@YxBcur6B=xb!1H{TQv z95=v$hDX(udk()k2J~vcm|^!g>qwg98Ah+VUQPB+Z>;M_2#sk5H6;}D&Is74` zE11smEl%j;OaUHe(gsOLE9z&+8G_KeJ*L2b1R;{2`yE6qXbbG-&CD3}2`NK>{p-DW z^}FB_Im(vpjXSur3JD@z1AP|w_JYOzzj9dKr^W0kvyBE*J#^b*Od9N(`Oc{S9^^W9 z&l+q9{Dx0Bspk?oCu>WY6kMhYgeq2@B4)4GR8}bff3rgCZck_9heB04f*x2sCg1=Q@YOL)Y%R8N>igl-rkmz&spgm&ZZSI7nGN+|Dozr z4Hu2I8=Ve6$a#CqZB44@36>_5CG963^ObfTU+ywhiH5)mAzh5Mdq&b6K*fYa@h#&G z{Jj`W8G3w9bMt-`170OPj%eqn5uUX5Im}im?PHQNCp3F+4x;;h7##b>TFQ2WpJlWQ z4JJrA?Uo+OQ>SZME}ZcL5jp*%&ymS7^zp;O@ehpf?7@DYa9WvTmJ9en4tBbK)eRjP zS>fz)^09l6<#t?VR^w6{ABKhGgPrSgnD<~S68QBF4wx|r(pgGs{&e(}gEF>SBNp5< z^o-LfLs68ai_2Y(|^0<~J#)7G2ma$0=Fyj&#e&VOp{34 z9HyQ<(GUPPTw*x{^T9^uqZ_!RY=~evZJ77UWw#1@d;o%=_B?DmHn&(&`)p|qK&~5p z+Pb@i3Zb#x;M5|K_vV;o>hoa89q2dGE;XkH4GU2t0D^&1D==PJllxK0o|XXB0YO@& zYD`*yf|YKegw**0+X(gKM-KLOq~O;IVyF4ntfgV;HZODJj4NHvz<#Q~IjA#~#-PS$ z9|mV-45m>Tqh1?vUQ^Rpbpw3qIdYfP;V0NZr+N&q*JVy8>|P40H=)d8z`2kdddhY^ zvl%GUfklL>LLUosKZ`8&eS?X?x$sO8N;^s1!d6s(eF2Ib9v_!3nZo=O(~%~{(gas6 zK|J?g?%Y4#jao?Lf6H_C|HyN!MU?q$B0C!sW#BGUWf?=8{cj~KIzp%rOT2d)pxa8 z-lcE6_us!6!M8`3&}F{d-FYwYO*C77nT$3l`Ha(=LZmiTDy%F-2_la5VjTfyDu^7g zEM(YjNHb>`E0zv2b)B(EcdJb;&FaAr!8t{&7q20z`CP>!z) z_et85GJR3)z8ApbXwVX5DVpP6(u(~VP#NTl>K3pSN|mr7DObsb_0?z@!XMFRsG~?lbpAHP7;1{KW{sj%_8L;68QNrR zTc`@yH|@>2qWM-kH1`q>0ITuOh}cs6o%$cFToh2tX!0Nh>`_Uq#3E3@iOSjiK+q#+ zI!<>62P+?*qCWiLvnob1mC$8u8TD_AiIIxi3?B<99FZb@hJ?~zczn~yNQEdpH->jA zfu&Wu%)`(+^_+w2i0-oR8R9>%9REj>gAOgQGui7QKK-{OC%zQp2mRlWT&)<`%@{Te zJ_37`X@;F37!)7T)=yfBLTixAMrw3v1ZxOb?$?onc?YE#cZd`xQ>zf1kkoqsaYFtZ zo`YDZHdx+q7@Rl z{9p;4HOYt-rif~SN*@+qKDu;RtHxZ=0!OfjTs1-Rt2JVwyFjA?RMxl8xlGDJ*-%n( zvvgI1_ss(+a{6_+;A#HOT7?b!lZp+JdLgx?r$JE-v|HL(sxsco3!GS7layNWS;Gz0 z3scQmqyw_VF*Q+OaiHoRktwoF;}6su@}23qiT(B2&E4La^UrbrWq)I$O{e2W?6k=N zYvYh0=mx)8vXZ4u`KeOy3MJK_x&&!ek8vjP9NJ4Vis<(9B#EfJq{WSO+kX-?t1vcp z3QB=QMOa#&i_JZQuR}|iUE(f>A!|Ozx>EUsSk%=c5=`##LXG9RNZ`T;Cl|XwCP}(P zlj(A{jC4&_)Tws7gbw&{eJHGA_5Em`ix?p*L{SYi zJd>m(7s>Poja6QWv7^o{lz_=mzdHmy($UMp#2cGiWTqK&)f_;CftF9_Ktg^9W+2D8 z-me!;NJU~pKdSaPaoX|E7fw@2{r^SaoqNK&c__>D{9378wcXNkDriNS^yV8i7j^ua zxHlOCHJ?n)+~|1gW7TuD;_WA~jT-ljf%B|w=z~&Ax6Qy{9M^V#)~zrms(9EpZm(a! zN_^LDEnZ}@(u2U-@#qi591`ZF!p8ZNWa4BrFP>TK$4MtPh`ZxU;b}pA>TnYgFMB>)~SStp0lXT2h@!c40ETX4v1_ zPaYoAjSRX2KAzkJ*5eQ~qXT*kNEY6Pziu)LOzP@Q-@w8p^c|HBz?80nV%3&*dlz*40 znS{yw7p&Ll-+u9j3VFy~EqTfF0DVE)oa1$SI|5k~z7-X`I;EkMSh}VA)0?n!`Ry49 zyyrg)&RAG^NfG>_nG`me!iF)<1%sG$mg>a|4JaSXJ2m^dqOo1JK=a#aB+hibjRqoWD_?@Wiwnt(gma` zrLPY|{~I2>z7l|E!LDakNf zM8r48i_;gMFWh8MiA<(12Fm~S&j$Iq_^(?U#@ht%KRn+f#thQT)9{D(Pt;M}@ zVHnGmdWB^qu2YD!b?dty{c^oAf3SWJnBIPek{PTgJ(4V+Q-v;^c&6A02|gfhjz3qy z@%0Q_sQh|mS0LckX6uS>>Ns9sYJXQh0nhrB8(~oMu%j{}K_3t|FRkc;BXoLJ=^>qL=WLZ%aMSU_5E9c;kWh%r z8Y|skPyhTELQm9+1dy_y3DJy@7onS2kHjsAq5gUj6`oN*osfgy?%IHq;wGzFDNwt# zW%~Sn96-_7<6o#ZjiS;k=a<;0HhQ5c$wL?-{qe}|8PCMP`ssyj4KL0mD0bm~Rz}uN zAMIO65Ul^gTvM?qx_-nZ6RA4d!U7CdJ&@K=O)!c9vDgR%-$I}NpaCRSkMzehJ$xsN5uY^I*Ad9?a32lehp=!=c1c~Y*byX-X zP7gZi?*Ap=Kk;YQQed&o@9Rh!$qpr?G@X*#_QWd(5W$aXv$Wbm+J5yr!14dm?3}#OZ!xmtw4lP5&1DDrxo>}N$#b{qtyPbCbWa?5JF9*w0J+%;Uh^g?4zQCa$In9 zx1L`o;w-8Z$u4Smy22-5V)}$H(B}->^4dgx<{@Jb3%&K*Py1!0yJC zuaBli&3uFN9z3b=6u7(e5w^Qy;1_dkeR>z0mobdM(wY%oXm~GrS~h;HoP4z6)?!|s zGmC6HxY?UvItvJEE>ZE+g#5u@$I&CgZxsQrp_|JXR&Rz3A80Ra$vB=% zE_xJpv}sAAhLmmQ?yg8Dv!=ZgX59^G+?N1UVGy*WSnv}e*N|A?3r$!kV`LfYLB~ZO zr;SDWiz##V+aqAJ43PJ*m<+O9DHC|wEP{$*>u-{NCv{f<>m1>=oAB+ zAR^2coA6_F_rd<4kLyX#aX#q==v%lMFJS>UX=q%r>vcwJHu` zKVgc*wtjvN11;jwOkQ!xVa^P%-tp+e>=rJG0Vu{6x9FR}VVaDxI6h5%ZPf~J+7&Y# zcJ%A)HmD{W%$GOJM-$U)!mQH{XZt#3ZX)ffhRa`|3o1iHLFe>)kE&HL;hRO>PC}jE zdwo=S2k_#qNksf`IPQlcmjDlZXu==O#%00@KvEVnAPFnAci%d_Zmgk4_H!H@+6pWe zSQgia7CV~BxaK-@(fJR$`rNd_d34_4kn^0y4A{aIsT4hdJ0@RW;1`3n`NO$n$)^mv&`48)a{ID-rop8di|bnhNdaEwz==j%fbEu6!=71SdUC9H#3+O^wl{T zDf_1dK`4$s^2xYWX*)EFY?S{e>9t||(>z>9K)^evBcSTyT5(_~(N$1-046q{gz zn(`l03NWE-BT+>}!M7MF8d`e7sap@*LXqYKqF`M+k}P(1n*g?}=2@U=%VNo?mNVvMR?WO6THM zFO-#{I8R;JG~iJ%At@XrlBJD)W}BOZR;9LHr&Q|sVQ4uV?)&EOm2K7@vWv;j)oNGY z4M2=lmy_G8)qQ(|cgR?92%a6?r#WD!Hk+d7<)$T75hpfAwy#H0wYxnQp?xP7GehWC zO|mi`Kpj9btynzj%o<63vw$mQc=u6Yi@+5f5U znvS(%J1)=LUsC-0w-Ybphk;ivDX@l!P89bEmK^z05S=!DH~TzH9^OW*x^T`kbW5pA2i? zlByb;okiC?dWv|(IB33SOj2LK6`f|24pi{D-Walai|PYweyv=7j_Io$l@Jz}3lM+w z&X<@4Xslc39*IISSYG}}al%RwZU+Ebx6-@*M|jZd9`T2%??7Vb0(XSXbty!q(1uhqDhmrU9tz59+$8l~g zM~&RFu&gEG4f%w@;^Qg$#ay%DCzCI; z5*;T1N7nDn-~4DjR$~!I^T7q#HS1W8R?-7zL%FAU3wyvP6f&#$I?3j?lxLIfDKiElKdOlu1aWUuw%;I=9FtZ&!R$8{_uMLz=1!i zUn{PgB3{KcSd0SVEL{mjEP(^gUUR?QJh61)NNw?u-TC!9D$NI3ojS(wAN;l|hANQu zcy5y-;D_UfrTeVGUwwXAHPm!tVkLDVlSYiOyGj)wet&SMZHg0DgCol-x*8jI?R53kt=nD6_iB$)C3}!EL}enyf^hk z)+C_~1R~#s)STISPYhMrq}eu1Xm%l7sRk!X~m^ zsZ4T0b9f$C*ra@xr6isrg?xHEhGxwddu1Zj2` z`{Do@;4PJc@EY*Tmp}NYObqwwoXo|&>H?h;a%m#&&DK*eQLS1vqhm(ne!tF)VtsjC zi#*QCT)P{0=6Y^^bv10q)O&6Vf5kybJQs1s8OIdsGRLq;q7*f0^*u)JAzZ$)Se=1F zJ=AOnG=Er7KyCcVtMBS+nOVN6Q7VZF94>%{A-d(>V(c8Lp1*So2&r zy9M`s^cd1(y^O7$FM}FL^%_4 zYYa^Kt0q2#iTdOPFKGr9SG_d!yQ*Wra2D&~Sfj!E_h~H?AB_k+Z(n_4n@`+ckCk7# zaW-Sa-aH1?9h4$vVvitE6J6#oyQxk>5wsVArX4zh^mn)wJG=}6qjvoE7w|@*wg`jww~4ko#VXdEYzlZQ<}YeoCxX4a<*AbO8g_A${IoR7)bYih>UEc$($;}%SDuq{ z1m0sV-utV?7T%ao1_VrbYOEHe&8+ocVHRbfL2PeiukpBr4rr}r_PKr=sKCl+)}0Jv ztuUw#W?p*!>%G>9KqcKi9`aP&TW=oxp~~fx*Gj|M!*0=2dQl&SPT=x_cnPs&w%@u2 zOgSswTMjI8wbB!#;+1r?d%sGX7zH8Z9S6wcwkXUGMw`PiX97FZ?yURR7N0n$m9Y8~g88n!jnN6DX!CJv&{p2mEO*jnQ?w7Mj_Y2_NFfMMG7czwTjO zuPae-w)o1)8eZWv!6{?MpBU;wvciE72jiPnH{(8g{_S|Ew%Sq9$CEL+ z)$2r=Of&cy?$U~#8<4#=1fpcDpv}%Mk4Ffkue=1k3LrOzz^3NJ`w8F4M$n2wCXisy zOI;3b3}(3u=o!W>EAM!r0f8mGbB*gUu-UB0GH)@R>_kjlFXt0RYWsqxO6Xv)CL_or zS%V_BW_99_W|_O0 z+lrtevLgFKH;z!hecN+@JbDbs?t6zV$~F1Vn0;gQt`m=3bIQ_ETv%^9howe6HC&a2 z^+q(-FJ`%>;#J-*QvdW~UQDASUO96n->JHotg&+IQ@2X<^EYI`vN5G+mkjbm}m0b^syEdK0G0U336{7PhU#S!K#yMQm99jDX;_WMQ>jn8os)C5@BT zf{GO=4TD;QZpvf>of03<`oP{W>c1E@kM8r-w?wLBoow4p`#owhH)SM(p4rW zMTrar3eC@*ld{W86aRV7Y~T$3w|srWxCt8IejZ?t<$s#vX{i#j?~Gl2As01n#KZ?N z=Vo0u@TBRI%fRNSZLnO=0-_V4g}kltTQr=uxl_l>(hzocF1*~lP@I({Rm)Mhu&y(x zb-X^*V*RYaUpGrNf1i+k*ibUtKi48uD}682uzUaUd62jxM*F)CJos~p$%5<&l zpA)H?SoDb(d8F>UJ!#ZK234XMl6bdA41LRYJ>{uM|AY|;pLF_0&i8U8GQMycrWx;# zY}@hC$tWPi*%3j?7ktyi$pOkllEh4yu>r*c+lVwY;pQeRW!omq@TnaY9{Y+q=VDd( z;Y3p}Fg$eQGG27(OkCB6b$v%Y;GE-1eYEPa{GX-oK;=*$uE5c{ifby!sMI_Qj__=R$!2d;5Pe_gkq+8ybcg9VT6*^Q zG*GpQ-?kc(+IGcxwPsNd|0Th^-X_DKA%}(8w#BAEyFU3Xvl-m>+NKC+w1k!j{H9R=ZcnPTWp64m;F`5_ zTyV6G6>-9~maaK|S2#F|&Z@}nWLI|m3riW7#nr4BdjaR3m=f__N{)3n95Lg|8t>eq z>EBG$U@rC)LAX_6kg{OS(Xf%I&RT7PNd~&5D7^)pG!$EUpYAK^eG6Bx^R-DX@w)86 zt7KeupMC`jKFz(ygmL*N-(?T#r~so%*>p);2!-!cu0-v{LD0vRZst!L*@T&~uBPY$ z>iEGM4fNeP4T70j5?=*KLr;XCI+cD^+4E~=80>2|2OHl;_qxOLheo-FcX(&GjkJmv za$g|0%BA>j5-Y8}@k3kCgxh^2YabX1jz%7S(Mf9zLy-g6g>H*6Y}KJMm1i+_@q9hZ zQMOP!5KfIkMQ$XFes)lN%K7e2S!Yn@y3?5{Cl-u&3gN$95->*lh>wv)a#=)AbwJ)9 z{~1Y2l|Go}PZ4R{4GZH}PF%!Bb%j}BoleP>APA$CY2+YhM5-SpP5LU0N3-tU(P!L^ z3EUQ{tl)!V;E4vhbpzhK7U*hA2R)*R1`g~wOK7U2GtC0eiZZ6j(N+d>n}BUU4CqJ8 z2=#&XBUKKF!ZDfu6e!3Sj~?=kpo7AKMgXpd>Gu+XSpZ(*vK;aMHwBJCe zc^y)WyvffVwXdcWnz39zk9Yi9uG*!@kNR=Gnzmu?=Et1sqtAr~yPzgi2BFq1zst!E z!N!i6%2qi%$uWtQ(&%5-1fMtgW){ic&V)<xrIJ@A%r)G z@s>rSIByhJkNdFpj7hYdDvH#DpCSQ=Aj!E0&Vy`$keNTYW<>-DjScDQ#ZL<_x+$>c z`^gr*DoxClyjQPD2d2I5a}03PY?gSWi+!X#UF}BVb-RYesU86?`=?})z#G4BqM8v* z7r77Nv@b<~?9Dhn2<^hLNz>Bt{3=av%>~=5wXAL}8s#M3Q{I)&l06zgz)JC39pX_^ zYut(FuK|MbGMZi+=7Daw>UF@K9^zt`H;=jZDl}&lrb+*H@I=R$f$Q#+^s$QugRZpW zEG59y_bb94{H=}cdmCq9uKKIZ6^T68PR46lEBz=R#A3A1l-y+G=DL>w(Hyr2t8W#g zSVik?GjjQl^9Wk$`|=fViiNEHS>KLLH-Y6Uh2!43cm6u9%7x^s*^aJaNJL4JS-FX> z!!I8=!nRsF^BYRt49~>rQK^Fmza73zD!`%)&;VP8G<-^WvFiptw?0)8_x0R=CZ6u( zBj&oBx5-b&z6Dow{}N?@BT4T7-}PQjfe{C{hy$SO_YR5a=H~clY;2H5P8u~!3$^@= z4vM4KbCur>S$6xLDZH-~Kh{d0>SfOja~DQ=i(|bd@ct$7zWm<=TC$Z_=CcMQl zU-f?>_=;n^C2;;FalTMEUnyR!l`hrGmK)|O{4Vl;2BsRFynZLKExdl?Uu^eA7d%lo zQ{z7T@9Dkn7ipUp>{%1S*YXj6II#Bjk~f%AximWZyjQi@LL3t;>!2Rz0u1_X8}6~7 zmGw&vo)9PX?E6f$Ahv|`a}X_O2Mh;FF9)i%C*OqcI1o;lv>$>c?#{O%lm9vVi>IpFbR2w}Tz@`~U!=-$DYQg7k3zQs(oPJj&J&>Yrxm#M`u6N*&6D# z7?0#J7DME)q}w(@54f|H-N57iLUY3 zS^9z2#mSQCM>t1U@kSS}ajf8~az$l#T?~Mp>!#Kg*hJgCauxw_17WE7SO81B-bm%@2_MyH(iT#!;;g<@06o*L9Jvn?qgg#MuIJEq(OmS3(P~4BnzG-`~;A zjAi-T6zAu7`ky-3Dgt}sK@Qf%mp_Nr`2m9paRtX)U(Kjf45_9hYi$v zB&hp;E+sEYUMA*GZjIC5^xkn1S5?Fzvem!X8Cbjp!_?;+bNc=nfwAl6*$#G;VY zT;4mmUX;Hk{$4!^z!Lqy~6+s{ZT~tn15dgL9>^ol%Jm8uft@-%y2oY(LY z!Wb4gi$aKmo?MVXIW&}pL7*NfO(Wn09`8UT@2#7$T(fFih(ZR}018O42H9FVROxw&n%N#iw5*%^`|MdjG& z)l`q#1)zWa!+i)!FWJqyb{}M(P(Enoezr}}0Zw~GwARy`5c(YojNrb1#-z+V9Uwb= zDr?oJJknXP)Ik5eW9>AVbjo#b<)#nPcGAC1lTzBXT6PmBL~dnE)&wxLA!6DW>^^MD zJ!@rfJjghwZ4ICpEee5t;!LBC$}-mOxUkJ+P_UINCA>#3@C|qpUPp-H;5;YFBsh0S zmF(4oBMf1+4aE+uGNh`Qv`U7}yt87oHrV#Pw%Tjbb2!MB#`Ac2LDg%&Y2$eX>4q}s z5>#$XA=-v)U6~pe zwpb`(S-|QQ@oEKs;+Ay)Nr@uGO(cXY%_jDZc{QShcgFW@Mw80-j}0Ec{FBN6miK~J zMntwHpBA6Erc?`s#Az=DOJ3Azfhe_$QinN`RV*ciX|?n~5Kp=Y=$bFBRo6m9j1>4M zx}Bovx6&A);l>Nm!ou&QrbzPCKnHZk0vvkwF!HL#4=$*4hcT>KLX>LVOo!(k{u6`p znLk>YvK?qL$HEaHqWs$S9+QvPKBk3J7b!xxt9jK!5)KXDVFnPb$Pk9G^nbyYJm`SR znEu08j%D(jhGHqT#s}sENY}DEiKi80?Q|Aj+#y`*CEg0c!fpUbnWjZmHGt#2ao_q^ae9v&Yhv}9a!qZVh+1iUT!x5)+*6d9!;UW7A%GQz%n8-W_|}I^{iUQ-8Bhj zMNEQX8#Zg*;ELn^w$nik=v%jz0;?xtpHZU(eMh&45FX-zJUxmhJ0zo|#~LtF{`P|! zHT20f8WQ>~FJ|2vx{r+b0c?2nq&QT9OM-N z%va#fl`I6y54WC+wxJjH+qgAj4M&+L(&#E>+#i@2DPbxx=OwW-6nka#<$%(9DMM7IT0 z)$TobpyL7;G}b_B5p^_}!R28&90EqJ$i7+?fZI$N*WRy&-S2l~)Uzhfr}f-#JUK~V z5M%%VfIk4>2E9rcw!)!c7ytn2X#fC7|6d0Y*|{q#K>z@2OQ#r&x}_L6yFmc}f;~q;Ko27;bWrohzhu@x;-$pkx z?~h)jj>_?9hQsd)rAVPhlLtp*KkabH(!&%V=cidM(;**uCI+8H*vrFKV)1xpzBY6d(|Ynk|B6o#(#>>YgwVc(qX?Y@MtsSlc? z23WYKx(@kiaayo$jw|>xSab`$#7S&)p!QObKp5{9<=or@Vvjw~Pr_Kw#<}el)c2}zUTNmx z_kiu;?+RyDpn?GwhQ6R+VbKac<8*OpnTu-`DXR6Hx2y&~7#EP*7C;jong=?5%cgOS72J-OQ1#SQ}Iio~E0bHjZhGtsj zz3{@RQEL)`aT&$^gk?n`GxYzEZ*#(88%^*}JwmI7u8(c0^@|x{f@fIUABZbK$_CJL zW3=~3wXP?Mk)>55oqtfsXnJ|7=_^A@O1MS_o@h=d9c*sJcBMzwI;~~#rb0Awr3LT; z?k2VJn~%NvNEGNRqDMS}a=S9t13;7j@5MDhB7#f-jF4gNp??0nABqm$C42#mu2I3r z%Fxkzr0@g;kH6MvnOf|m8W0M`aa)3Fq8s{C9+^gA?a`-Fo4Ey*93BaTpvM(cM@2tw zc4JPeT<+t!apVhM?kt*h+b4v@1qdT)0rA?3J+4t%4wE(hZ6R0u+hdNt4k;J>Q_*2z zNn&ZE5w}2vaZ=9;q`$OFDhzRt8wXmnV8G9ZaS*C=dMXxYUY+=s9b2+&Ts9$VzP7Eg zSRvT@s9dk|4p;3ARD-l4j@+20jQ>3(K9{%i9z(yckH9Xerfcdr}=ES9&{Ml0+0E|T0bK&%FFb3g0T*bkz>($s;=|F%k1RA(J3>Nsi z9QhKg0Fe)DV8E&_5_fJKvzG~=7031W`U@@i3UfI+EP4&xE`aMJ#-&FI9|hc zY~P^i9bVaEht-9{v4WR@B3=hovxU?}WoeH<(323GOb!o#J4ZJBay5itQG&CjLs4Dw zq~_y5G1A_gglocGSrkot9oF$6_&QkXcZJ$1!=skRvO@)WF#Jd~=u!V3q z`;uR+;#BuC0=R|HC~#bZdHI09R4@n!2t%P_=41Kchv?)i(ZL;{K$0{rp6OcSX(DU; zHsIeR^u68zMpAPF>|s!imy)~s_|$-y2H>f{yB@V9CR7PBD5)e=zX=DWhtaXw#9btr zAsM2s;MZ7IjNG#JgyIyd`@l&ZpT47(_)9%l2a$__P?|Xn3*sEK4f+tf!ehrMBM2kQWW6%SSsnQF%#_0fp&^+@>NG5;U3-XTbsC2SLI+qP}nwr$(C zZQHhO_t&;<+rDRJ?!>>CMOH>7c3BZ`<)b#(k$VkjVZzatSIJP;7xp}RMcoz4mZFK_Yge}an+`46vK4R z!bqBTf$5chdHJ$ry-aagtx&wXT#jg`C6?EpD5sJqw!LtI^ssa$08r&qV93P|0@N5B z2w)1Btx@=RQD=v2?tvf?D5eU>lknoD=#v)~^!mkgCMYgJ?|2uKz59Z<2La+Y%r(RT zqJl}9e(={|(Zf2f@ECul55g)V01wGZ+B5!5kfoGaFNf|ClGAQCrK9Hw3{AR^lp+Nz zz|g=X%J@QwB-`Tu!Yy&4K}CSJrYFz{eC3=Z0&<-85qbS7!V#E9{EKfH(8d0RR(I&x zNNdc=bca}aEh2}W56J^`D}e~IpNt~0uLKM-1)}Ix$IJc~7o|0*$QsZKh>E9c=rwxZ zw-LKm{nPkq4XoBZh>;Vcw*2^9yeXaaVo>Mkj97wJ z&~t8%LcX3;(AZ{^!roPlXF>{UcNJ%baaLzu!DCuHfP%e<~clP;$!j_d# zB~%4IEsYztXs`}?kEL_r8*IMAqmhtq(eyFK+V)}S&6lbeQEZPF7C++8G~AlL?~9pg z0-Ud0`E;k3@8@q;TbSEtyzOBbNotz|SoR9_!dTuiwy{^9{18ieEE)!U_9%Z0)b|)tbIB*>3UxFxizJJb1r$u-A9?^Yl!iS*=?64cYe2g!+l&RKwB1*& z;0OPO15;HtLgi)7-tN0@T<NZ%`)b_gIMj#Er1+1I*T9hkS;EYvPh7_< zsH~G)8*RY)J7cVYe#C@;vL(_=Bhdxw4x1~nKLQYw8h%5lZ*Iaxq;T(T5^yu%aFMj| zoz=;`#>!SF^ohz`xV3JbYdQ_s1eS1eI5zOyXsYng-1VG)5{-|H<%Z(6)eQ8kZIhx~yjq0kWY zqA`h0{UQLfpHSZby)CSLO=S?l1I4gK0(UOp@gIZ=NbEKfehKn35=T4cB4?l|U(rA` zAfNdt*wF>yma^t#Rzj09b;(rJuS)pDR`kR3HHgm+51=|I8=2gmj;`+ZA|%KfPAkF7 zMw}6(+K&zMA(XnO=Io20rSXi;wr=esfdNe%-jES!jx0$UPGUQeyy8`)!VKuA@hcbQ zf3=}`I5_xR-T+zVwkpY+wd7OokAvUW3R4xe1=ifu^EN*X8V($dZdN;d4y`G?Yjfl z3HsMdD2aPU;!_3nY^f78xpJPOLfa$Wrl6BgKM{Vp(hy*+LICj`Y$FE*3JJ9mO2}PR z1OpbOL5UMVvK1@}2i&^Lxzudt{bHWdfyn!e@wyV~w_pb-OLYipxF1*tY`}&A&t#4( zV)!ACEu_P*8>%RADHM|rP5y}_h+$(5SwqEY@)Z0^GWeuK1zAo!ZwWc*Ng78pxJq@! zwrZ*o_Ug%S6`-T3HmH;-^>LA6CitW}>N%8LeTulX&}RpmC~kGk84Kz|jH{8y&gpLg z4-54nfP6tsE}&Wn4VwiNbZCvbPH|^zRb}iGV6Dxv_%yoIim1}yO^*<`PAaKJ-#NET z=*55zHtEoF<@y+?%b<7$ur^308mZC!zeIF;G%w0pxdPn% ziiZ$khauboD7zM*L>3~b&$ zysFo{5@ZW^G~Vu+e~{ivWL)VdPQMwV)0D#F@* z`eWiYA`-PTL#Yrfqp6W=;7ymu(9o&ijz)>@*C_8YTCbUCZ0{8@u3=S1>iO3;6Qd|3 z>ccKYNB~pS4a+GDS^s?v%! zIh4fe;@t5hCRAd*;>;sJmT{0;Lh_P&uzs6n>qD^ zY{K!YPbqfeE02n3WaIkqjf!vkB-<6QgoZj7&eyC*?!oi~u5`NH){S#?0ER zQcAIHI*Ny$0Z+RDO&mPNt0HQSk}t#~W1z9)vQ>ktXc==6#Pdk4+(~!ZNrdRfa}aKT z*^}IaY^6my0cK-x?{K@y3q67hljhfwFs|VqL<5$B6-6r>OJ^i0K2S zb4`vW{{a=-xEzq2(>4>;4HZy2F!`D}O9LX31yvh>i?SNzT)(eM=G9$wrFPM+^18Sc z1WZ4fR#9nTq}a$Myuv~qpu{k|r<524v0Pw&Svi>;_u7}K?b?Qzk~>yXSoM{D=HXIP z|1%7c*syS+vx|0&2F@t>+PA_nVAVyP+gN)n%>iIh%{mTO!gfGr-05wYj(y>X3B2>j zL_L-48B`pbCYi0ApvpopmR204OU^RRy6YBgie8K1?Ro88--k_Q!AnUF6r$(UqOR>1 z$CAM+Jc6pgyKSCO-yT<+Ia^hUUN5JA{CARY_c0I_(@{vL=2>&@qsvPvXCfzGUk*&8 zq5BK_+m)q*H>kffaYK5O2|+ch{8G6nL)8YWGAQ!{i#8Zaog`;$yHGFcToEp*{GcT# z2Bc&lwYF6I#S!S_hD20OmmO5UheEze{~nIvqUYlAE>rN~ZD0=U2bx}VRm_nf*=HEd zfw4>xD#HwK0v}B!s+a)3S+p^F_o)UZnBRU=(65Il!N`fNKW#^5PJY&Ywx&*#n!c7!k!BBnvH8D3p+KL@ zNX1mf#fy&x{v0iF+W zlG^+j;hDNND!NJlIb_slwSHaRrA@~cgqg*>#BfjDq3*i5YVNWe`>My^>+trvy=?AY z$5ZJ@seLY-ac3`2oj~n1D(&TKM7M)9Mf);ZMF(DM#E4XG#1jkqRuGMD_1Gf?=ITq! zL3*STd7Y!nx-w%`4t^X&k^E|k!|N07Ql`>1Y>u+iQhE}THAmmtiVHV`ArRTSCOE`v=bl?JpnrMdf_GUaTH{dY*NU7pzBbdO zGS<+F%=JbAO!U|H;M>vV60DA;m^BRV#Rz|PAyG=%v0^^CWef)T88~nI&Z!KT1g`IE zfkyd$v4GQWl8rQgT{--zz`XCbVAN@y;0aaEuu2Ul8v#tTa|m4})D6R1>1X-9EuuRaUFU^T%_I z^m6qVgJ<&E25AWSX|_mt-T{V3+TR*wes=lFB1`9X+BQP=;EqHB{-b{bp2IzjBx?2W z7YE)Rdo%79gm9NOvU<}Kiw6C1P=lW1o0s`>#n)tZ+oFo`Z)=oJ;2tdLok9);sb5`J zKnkq{AdEC(ph{bJQB@pi$(}2_>M0B8zmf&*)|D1x&Z1GmR1}1j-;qRwVOtdKfl?)% zKk=bFM9;t>N0hByTG;7TNHGOhI&$Hkydm+OQFinASs1=&Dj9;ka4s5xMtVL(az2@tb2y0im)&iTo{sH!-1Nawg{k$Rkg#U{nUmgL%dXLD7l_z!`8ryq)DY<;vT)qU9 z(DqCPGR>(3YdDdmGstdXgnV=Y{_^x)4RQoOAUG*b1+5>SaI@7Avw96%W*h~mZ( zW~>-UI!(tWP?%i1_UB5?1vXI@jG3tqM^+4w^dG!7(xuC%c#dl^wi0`sz>`>H%WRN& zu?$uHPk!=ZmnbBdb71c{-D%Snlrj&@*xgd8IKiv?%SgD`M+k#NWxkAiI@c zaU;L{N^bRq-1-x_`M)RH_!a-3;n%DGwWEW7!Q5)^$$s^!Y;m`2@T3hlax+fER=lW< zSn=d0{z^iH3fKr6Oc!Eg?kh=Wiw?H+8d5 z>TjS=N>$v*d;W8<4S$LJ)%cVDe;^gFpazx5ZAMUF2mpXfGynj^|AACYJq&FfY)t9? ze?aBEKgdW@=KldyRy1twxBemi-s&@&B4o5!sySs9DHH<3MLP2q%z&bo{un^?uy!_O zBTf&q-v$4 zRH%rVXYM3U>Zlj3K3-p={!nGN(ZQyw+2%@Asi?7~q*|s)$QH?5D4M-pfxT%}lOV^A zD6Q5=CZxeuq8bPgT}ho3O{iEBx`;qOz#_atYFDVmtB1Z!anHcMw+zIJ=6j-CY=Kt8gQ^!p1H~sdXaF;Q#GA2z%*FX(gddWML|lNv6uh z{v)u(k^8`j3%-z5UqM1MaBTr(Odp67TgWXDDtYX#d3c*j2UTgp`k1XSG+zh+{R$tv z-{y`N3|abI63}Y9@2&ARTxY~RN@z+TSx#o{DUN051`k5vj``rtSRR&MXduExu=h)F zUAkc_3{aRjL331QBcg78%wuccVA^(;Rne8!rF5XYMCkH(h`%_f!5bL3B$Uo= zF?c3u$CU#w&~{*YWOC0^))cL@@;P_BdLI64YA447GJaF3g*s(puT1%Ux)M-T+3(bTFDdYudmw!i6Ka~XJldtG(E!?sWW9@)~G)(LvioC{xI)~n9jCYsh{y` zquWWnRZodC`AAr)>Ur_|*eZWNnmHSt@s6jxqV@Z6I^txjOTn1q1aliTO$a02Ud=C| zj{3>z|*nm75hY&mxDwJhu5H1pxuxzeA#<`+n5mIucy6Suzgr>OxJUJD0 zxqjDZjV%q8ZmC}bV&NkeJNd6UX(a4}X2s!F2=9LGT%)SDSql5b!mkIZgzpx5= z?e;03y65EETe!7Ic`27%{@CJE>vQ$2ca$gwjd+ad+cA~Q%b4T~>-E^QGgqM_(x3H>W%6K04&n7vV;oWX4woKl@RExc3(E%m4h(nR7u` zzL%lt0s1^#kHgm3E*0t}Alb{s$wSR$W@6B_VWp`|MN&79J!L=R2KqVC*!-2nR+j$& z9_=iIixG4EEMpju@8qd>j|JN@_t;|l-0a_a{{~spVYfk8&Z?J)LbQyuzs&wlN~Bfi zl<*t7(hzG5La&JWbF6nLv8>85XfEzw5E)Q-28Da>%`~FE!JpQ^0F|T`3%aE}r+)kB zE(PF^om{d($?yF>9`#<@Mp^1DYD|q|%*1kd?M*hI9Rm?dLZ5hhFB9A@v}xunuYC`$ zEsf(6s~HD31izYilYU{KWqngqYIwKK6I*$i=-uH}*(>vZ_CaP?mWsR5{OKo>5AnKT z?(KUlD$Ysb=N|aR+>}6{fxAMRy$ZT_tlfHxq#tLBD7oQ)cHQXeYt1KsHs%X!_DpxJ zFuV&Mg>UqCNcjuuBMNhOi(l>IKQuMp=64n9X)GFN)5~?R7eG=kv@}|?lv;{gt@1$& z0>SRcxGw_kM6qvDaEtfgkLBb_>m@`EZ-*|d_iku#0G;Dmuijv-cMe-4Clm1(Yiio9 z4fR1dV&%b&(^X{csWKic%&Z$HamrywyOOB1=aZ0&3v=OzBGG-DFTsTs^VP$T8MHKB zQCW#AHhk>dup^Aet)zT79v;U!HH?P_GL{`G_a>9X@~P1v9TB#I{iqb9{R_HvN%lQS z5Hm}bgbOPHe2S`OV_*rjP1`ai6#pr=pUQRrIBPc-)e4wB7~-TA|8bnoza3^^jyA5f zuKCXx*t>BEds=6z<5_tIbwU{@j5c6@r0(T6&rj0zr&qMLrmk3U7}$L~_C)Iqf_75e zDhY03_I9p2`D66<3M5LUy#AS>1xfQ*nM`Q&=oRX-lxPUkN~j`QMmDish<-?>nPIdT zl@uYWg`o7*&EWP2r2bNJGBHN4k7m&hRg;01ad_<>`cD>5zKrl}hACN(G2@bf7 zg$EgU*)k;xW2n_8n_(}`PBi(7rS-CQ=w5g}bs`7A2gKUm11*Ke z%rQw!S=vsHAC%bo{|Oe|`e20AQo|x)d@jukfDa}okFUV6A8L1cPMR;#!&1)%<(X^) z{j?L=j`a-2R)WbeT11uw77R9_CU=T*ymYpr}LGabD6hFQ7(jZH^ zR{&A|1qg*!nX1biIL+cA`+UQhXS=fE|B<4P2I!4ngGILN8-!=nt-Cq9hX68`3+N@#^mBpu`4TpN!+OfB6nL$ydoURZS5j3biC0X zr&h*($-=)qI1rDk{^88uy|s3eQ;xWa1f2m+2rwXr$d@+Rs@@-OXgiD`JPEEzpA32r zvr%sbsVaKb-^HA}y7WHk{ikgTA_lN{w|1nL2a1sa3~2rX_@8Qm$kRa)+uWM&SPcLG z@DmUK{(q_o8$$;}V{1CI|4q)YziiSEd2Z7GKje&a;Qz=O|LbwnYweE3iNx^j>mQo; z#CHZ_LjcA-8)M#d2GE9V6O2oco@sAuG2T12UrLz%bN~BVPM4&mRGmFGCTTWyEeErs zbfHw*RjGmm#2@Tl`}@&tSnf^&r;p#;yG|QvC;CiPq={%Aem^%c`ei5zlYK{ZIPCd{ zlJ}S|clWN7^4I!OPfJ*(>bTlt(I!7?;pW}00}^e)21{ndr%hL6Ng7WN0+%V;{B*;?ZIjcT#Li1>cnz6?{Cye;P z4QYzS_41o%!hPk+hyjXBP^ZN#Kdt@n1yPv!Uy(Zl;c)SqxUZp)L)tv$^cTu z%m>fA8Uh7T2}zs5?Z?}}NB8PRV#hgtD|hg$Cp;dj^fm4j+f08dREeY{jJMi<`r-$z!MSZkBi`VR(;seG0kh@W8MRm{vZ(-E1yY5v3 zl`nJVfh3XCh0x}wwOqHS>Fc45EqC!B{-$mZpCH|Dh5%Q9KYKzv`8j$6K>_tH-p^oq zZ-xy9jIbwv(NALV4ennLh(EuY2to8eV*=oJdk?>b%TI};bLwegy0XDXr8;tB32}VG zB(K#B2h6v4>cjh*kJlo?KOubhxv!me-*@i!`JRf1c=4ZAP3HQ+qZ5}9Xire2xh(PC zw~ZE$^(%Mmjoy<>R85+l>{%Da_%cV9$#c2>C2W^XupT_3@{dG?BV1h$ATU=>$WefI zm5Q}&qCGcT zYo9JdBHapDe@&zFg-SppK!07D2g88sO|LQODZiMb2bJxe%ShXDt_Mi6a-`-o^B$DE zLH36lq7$vwxWCL^)@(ZjgA6+m`bq8Hv<37${GaR%%9J247=gLm9NJU8e;!zvCA9@t^1@-wc5;6EI%btE3^e;dFy&#oyIj5PGn-M z>K!&nKu+P{J$7W%H3jD#&?FV^*=o1b`Wc((4n|94f-)&EV9M_8X7TOraC3o=H}ufLZ%MG{taxM9QZhr;_4)+q~}DzcNOHz9vy(08!kEktQ3C&Gw|KIB|s~3 zZNbTFfw7P}&T>DnETVf)jJmQr7Q~_gQqPL{R2H6dBYZ1@T22rJ~xkp;7fUrP#ay8JK02 z^NIQ1cCh;suAHb*nV8dN4m4(#aRIUI$ASRbf$9^L-v)sgGh^?bs$>x;?o^X=6Vl^Y zKG}FxBHU{isi9{+t>Gt_SuA}Q(!S|acE*fmLah#i=m14*IrAy`H6R%kUWGl65QC*4 zl_bC`lHlF8>ZE_OoX~;RWhTgwE~WARm@tb6Fmq{D%##fXpf3Nrum8!a*1*rSpa)Z|%9-me`otku{SM zhs?m}K%FytN7YD&9loZbP=!^iN*Ob_P!p+4i8n~ee%v7}Awasv3K0xEW7 z%HCN~LK$4`o@nPk{Mx|ChEeL7#{Ab=U9Z3y%c3KCa(Ok-JgvRi46$RFI}46W-63k!`Ud z2dr^;=gXGsW9;NYDWw!f>Sh&&tiz(z;iO=iPvD(^ABYdd0S1o?wZfVtC^%NO6sd~j z2D-u5z}2oGBl(zdRG~iMm3MddS;Dh_wyW(Uv}bX9aO_zCsP|-#Cp(X-^G;CM4-UY) z9nxEK|8W?99(D3#j}{h2Jv);DaB3zLarvm30)UY~Xl##Ytn7eAdpfVSz#{-?f!`Af z_T5ley1F=W*X2Yeb%IJ;A<67PKY4YL`~sc7^?3~~VY}dNTEQCnU_W1I8rd>& zzR7gRM%z9UcmUxGjRHtiLp*{IleI1k@wiBxfy1k{->#AvmUH=d#WVAXOM6miT% z5(Q5`M;u~5qIehi5^_RVhD4sVVABm4t!Eisv^CW_HA{DQXMm6PbU^>LM~g+Q-A?SI zcrhH!Qc&5T$neu5Dh(#{i%w>t{WE*JXUduG)6lKX2&=)! zUt`8gzMj)Y1mMk52yhGt>lqN73Jd;V4{&CMOf)c71o|b6O9z1Jf_)W6kUeY~AvY+6 z$dwr~i1AAT$v;Iw&Lkko2;SPauGG7rdS@UD>jx_(FzXVaHf={|WJc4A$Wl><-wZj5 z!RG{ik>4T+?OIQs&IbwP(Jmf@paAE-x^J~pPAkDt>AAb`Nnxw^M%oJB8fNK>d zr~@W=u8bf{zDGs?&Sc*P1#iS_4;m3^s@f}pSPTIp0++NR#kEBHL-YD50|~m3tpx01 z`MHz50DGs&*d|!8+waxVb;^nlT3}6yoMcGI2m@ETQWGv=C+HSz)CG~=&(447udO9a zH)wbd6CrohEenNm444~xnp@V?($aWwuJl7ty@K!!pK?-u*}LCz``K@cNu4;xBo-IE z4p4(n3fWaFVxrZok;2VL(uiChSl#+h^E)@azWEH%^^~`W`=Vwhq)6%$8(edPV|Q26 z9DIR1kLs93?7*EHdrg_gdXi@J_wG8od(hSG3cp)XoO*7zdhuE#+nMjZMtgC@<<0ps zcG-)gjn41-dfmoyv!5mq&Tb$l>wN0U0ecnzK)+_V3UDgRkSk_DVBBe9nZ*{%q#Y1Y z@L*-0J%dWH2Uis^gXA8a=l&oW{$|Eh1FwX~Z8`2a{+g|g=Ja$62Sc}Fd`{+u)CDC4 z=7~4K23?O9M+<2UQ6~Df;#Zz06lpTkO)SRFIUqX60pFv3qfuP1{v6OWL#w&_kZ|S# zf!^D${s`qfEoDbv{9a%uiHto(S7~6cnb}?)6c->CH5aXOY3V^sWoT ztn$~n(I0MD7CQruNi9E?WnF_>?p&iU)LW@XSf?hZ$g|*R6n-Od3vy_LN0;_QxkYPb z9mU>7qGvL$woeL-490?U+39ci6PRvy*7{I5?2ToD2EDhp#!}9BqU(>d786QtTvAjXoQd6sFTz&f*$E91jXkv*b;?zMKLw54R6zPFfP6;?hRjG>T1K3KE#43`4 zw$dp|fB!-+P;i0J|N9{ad16#D$o{6#FXE8dF3IJ=m5fkjE<@`jSCZ-q5?o@{9b7n} z(r;i5QafDpWy=9y!tgbE7lx;9f7>N|tID-1cg-Kn7G50zL1~~Gl2Q-DqCL@h^+=-y zZ;}{o**H+b6&~U=ddWLbM560{kGCo}Q%SKGeNobev8JhtdsTnBb0yCBgj}0)%7%|u zMwH2op8aCgIf>2RRism3^HT%2bZ2u)a04c{aLkL&FQC2s1WUoHyQ}2zK6~=@FZyYT z><|UFLQ)83NMrm2RkgX-efDe{06)IXnd=Mq2aIay0-M7XlPZ6|38~@=<9o^NwL)(| zV}8HaJ<`x`;MED-Dx9~G)*Dz!25S8}`nskho~Ha-Y*F6$x|yaDI)XWkr^iU!JiLz^ zM9R(}#6Xa~=x0*(**#wubHK_OvR;eo+oh*M-n;=jJNI9xSx!V4z?1>O@}~k{&jfi! z*67R4QrOTBQEvddJ{1!5_(nJMWTFolVr^-KXs(%S(PV9Nt^0MANY^6*stj-dh*fS- z8g8|m54<~f6J*ex2j<#C(-KygD|eij;WxG>rR&2NHR1t(m0Boz`*r#WwkeKJAgOK5 zkK+(xM5<-^x^W2i4uh9Hl!quX!CzY-K#Y57_9SfQ_xU`K#Oq(^lP2vGBk4W7LUqCeitoM~dJqPPxLrQr<$iTqQrG0V9V z3Ei1|hsKidxiq=M>UG=R{Z-B@T(-d-73?(j9Ebu{m5yBfszZ~K9jJn+db!4XprMj` zRvt|0r#(IeXqM)K0A*f#>MnmC+2hm7e@CM*373Q{)EJ*4f5?`hOH7pyt`3PGK1I=N zh>_bSLri)OY;IEE(k&;Ahr%A*$ui6p=21)vZ<9|DN?@Xx!?2|xUN~20UNMs@qRh6F zWIl!~@ju^(I~0to`AdPG2OKldD;<^PNZ&(d&Ib*dY^{z&dZj9XmuEv#IfwuU`5b4) zA-eL!OxOZTz6GzQez8(lRN=v5-ftQjCy)auO~!0oYCQ=AK!xnI8ddEpbMnIk`?~W7;d)thjR3Tl1?2ZWg%q_7n^eG zJb(Wy!NFakS;{|s=a)VQ=qn5CM%FMGanH(LdwQnx|2b2M_lS4wm zvB76q`e*}X`hE|{dgH7#R}xEYP9aH@@`{yd7IDMGRk`}(EF059f?QewLRnQDg|Jj< z@-Gy?^pV)|(L40T8Tn3O&TA$4Qqr1x;s~fUNrkSfTvHB&x7P|q4n5UdI_x>%6wGS4 zds?orhZ#s`cD`xUg!UC99Mc6fCuQt3_kS;X=Sw&KKAnz|g4{`kEpGd<#?4vt~K zJ5pPJ37gG8nX=7>RO5?qI*u)~CE7~bfX7+d;62mA$fdwX2#%V?19?w#?lo6(98+p9 zWloms_+JX};^C;m0H#O;Vx+s^kzKVNQ~RJUM^s%A!$T+KThKTUPXp|Od9OM6>OW~R zeQNH|a21SGQcAvQsx7&6+qtqoO}`|Z4C_H`MP551g|yVPnV{6E3#Ea9Y^Cj`s@2 z)lGmgE!ME(!S#5z(;rw~%{=7LUgzUyYpzrua%AxN8Jm2h{@sx1ngaQ2yuPZtqq0ND z@n&WYQmqpZLyJzqbCPTt>pa_LYS{b@@jaN*Ey@kQw4-XT27Q=LIlt5$)VdZuxi`I% ztG1|BRd!9DX;^j-l>ht{U4{=}%)Aa`xMYwlg`EZLJZoh&#osrC_w5Rc(g%oexBbF%$N4$B~{|sl@8Y#;H>%(53XintTH%DU}b(bhPkUGO)`Y> zm+}4OpSUvnEn2ijCctl7Enx6Vk@-@NCNMmBFezaV-*xMGN9gAxqxrE&9~y~%CAw*X zPSz}t6eq*|<$PkrcZN17tu~fIE_>)7{Li8n*J^9WUfJKvVKz+#7%_=kP2=;{4J5Tu zmJn7{GHgSFpZ!=feJKs1{8Lm?O?wP8`Jqx2^W#}^{Ub7L+~a~sa@o=JFIL*|d*ZvP zGPWV`_a>YVQC5rav4VdAQ5MXg)jsf_@A9$d#UT?m1!^M(w|*UXe^d^!_6miV8S;4drOn9zQ1c^+^+ zmBUz1nk0S`2MHk8q15XW`|w1DA0GBC&U>Anee2`?Sky=g^^>cAi|Ghg5TmV%@XtGX z|9*-CWPWM~_Z}BMhv}$i_QO%}*{L_kEvd5M95L}+=`FtMr!aZ~!UKYGHtqx<>q7t7 z?pG6YMk)Q^DGhYeHC1uwC$NMmf`CT+ zR~F)nqXo~dd){ht&PR5qER)2p|M^iH#J8Kz9^<1lkAJIUhq4pDh}jx_&u znKh-N8HOeyR_siFss65+8p`+JbXAR8VPIcpMdB@Q#`7j0!?J7~ndK@RzrLh`L*LS* z%-i|#%RS=EME~mjFf*+)??YP1a7ew|$a%?;luJ^J7wwGd`YlSdK(9k}iv#c<4r8s~*p z5Jbi|b8dR}V#W~vIq4&h5oQ8HnN%GFZ;bKeBCJ1g-tk{_V-`S=Htw7heohsp#rm@& zbr#yk-q?5i?VuW~myq1=hmk?ieEBTqE}(Z$Cb6XVyhF7IO9%rh+V_O|tZS2X9b%wt z#-5-!j+C0PTeVR3O$~!Bbm~n=?>ZCf9+Ufw>XxyFpveVVogZioW6;00q+X($Je{|o zi#+X)zoS0HxWePt6yMM~w3H5S!=Yw|H2)3HkcwdW5B>w2YP1$QA>3)L{atWNX3JtA zRdZ%2S=I%dRkr=Fi~lBH-Mr|nZDr9YKcyTqa+dzA_+{kfl=ZV8*mPdn zx+n*&RW?1z?#w?FI9eVwa#e5m0$VU!ORfB3w4}38|vEX-6SU>=dpV8zuO|-P#}t5(VKz9Aq(ZcTCO54eMfU)kgy4sOcd9(iF;7y8j|(U- zSw`gcM4V;WmO3|_Gqc3PWOZE5&ig|?Ynm>IF?0$y-QZzAXI_p2Z*jUyzdKK7s4SaX zF+ved_R`8`$H1H`i&;>91S!^u(kd>NG(J}mVsWn;O8r};&NUm-1{Rs%lpH-bltY+J zd;Xnf7Tae%1_RIuU7{I{eLHW2aG+zv`Q~ z`InbR-AMN=wLyp1qLQMNW9p~mT1rzlh2}2wNY`q3!t^h&I zS{HOdghbG{#<#G5p)OQ;jR-?P2HS67wVQE1j8&mJSdwwZ1_wA{?RYmXTKqTj=>26B zax+eUn*qxOEj_8?xd?=Xv8oFUNH=mvFjY=>yu!Ek91EjteTX;-8~G zq8SA7j>yIR`yhblRYx2z!X~L*xNg^5ZyfT4GzbBFk%Ip6Nqg=EoIahwiN6@bJgk!6 zPy`*1vUi2h=~ems3s!&w9eeVds1|x0WFM2!5A-A}>{g%OR#?0JZ)+oq{>_Zpo6`O+ z_db;F&iO|QL$h#YG?|41X1c>o%G7yMNo1+z(+Wt@VOH;T){pt^{_%}-KI(!c*D}+E zEUXw>W5{5O6u=zNq7Qjean`y?AZ2XI4jf9`dr)WLbc*4?3&iZ*->Sn4Y#u04NVwMY z#MfQZ*l58D+kmeeP21W(@V(c3C7Yw|swd#+ghegP5mD%2u|C&g>isyi@K{sd$wu9f z0reawn>7dpu5qo;&BZTd-oXo00%y_79TdaAe=}WonPS_{evO`vj<4WibH@<|yK~-i z{+oHHx2@!Fd9TNxp8Ko(K^O90t{$uP_j_(``4BRrw6|9~QMgRJr4xqYYV3h@$+Ap2 zipKgeWvdgHpfyvjCExg7oDhM9yMWbM;_LAl%Chl5yA0m?%KP+=$h2tg%@$I>vX(Jn zON}5QVZm9N8y1V+@zR1XUDgduKS!Fkx%9llQ6g(p(6@m2@^fT+#|`o~r4cE?D9UDHJe?Ksgcz%+bsJbxoJK&n_Ld7T;4jCTD4$(PtE8> zUj;UX?qdt}oxF5U5U5SVr~E1d-=CbQg=7sSD!;J@=OvKeu+AN4MErC$LcKO3`xV1^q9j~j9l2&4J+n1N>eqfj%WO7L{BDuhv6s`F-)0x?(lon z`*M^ow>Apn&sWSNK*QR~$z1{WlE=+Q&j9i8W4VUPh4!OTG|G{*L%2j5`rI9NmhY=| z_=l0$i@pVxH4>ARtAwq+qP6O}|Lq8S1e-~N2>%zKRB6ou9FpWli28(YyGe+Ap9x?S z@>$+~H+!xoU+u$R?}Oj{R`2@gI8mbobvPNLCFq1{IUyT1dfeGG0Y@eV#c=k=S|N1& zBb1L^V}>OjQ0?7=v(P4g2*5%}!YD2WA72>mGh>Zg?`cbt-m{w`Dyips30GZ8y+iWf z%@CN972s52D@0?<`6|wlkhibVwiLE*w4+BU(s3OY5vlW;$gLe8i;Q-f&h#Z=%I`IF z|Hs6SNBQW$$6^H_Zl4oVUTw|-{n|e$luSlCqdhtk&tX5YBW0mmk4Ze#GD;zf!6@Bw zqd!c@niW4Ba5;K>xlK<>b6lAdL5!%QlbrQq!w!fd$r@jSyJ!RFQ26WKlb);frQ?`1 zkn9V(ubCR`ljWOkS8q<&*rD=C=_)hlToF%UfgWz`u@gLYibOjkptyu8Iksw z^bFf>H8~%WHY)F|1JVq~yF4+cpl#s}cKhRW`W1!j!VDkhAgm)@&e2eNT})XshKRc} zWgK@9!RA`(<6P~{jAb0SOR3lx13@c{QUH|c*~~*)NCabX@-vGS63vEfruU7&u@yN+ z1)v^5|8|undKJ)QG&}Hh_nRO7n$#;&?oorKh7W+=0U=;N{%|<%(`KX0h7A?E-~W6# zK%v){wyD@=Dvdmsa$3?ZrIZTn42(_dnajlG8%D&ya2kITW8J=&pUO1-TF_6y zZ&4=Fv1Q{jQ**ie#m`IL%jV^~qML8iRKLCtXw*{j zuOsquvMT>m7f@jjlmV|O7nDP<8>)*bPg)z3uDj&c>8NyiCsdnngLtCRWkdtu_NT`* zyP(bpcI71foa$$*Y@3eY%m*2qbCJUcING;39|g=fl5)Fd4o;290hH7F58r;Z+4ac6 zH0F-FsQDGx5u^Ih$NaFzaPg^{$eH)IoGqc-U)%gbxWA3NyN`l9Q9k|Kg&vaart?4C z)#)bmX93V9t;8)UZdBZu4AGPCE(mo#xUKwBqhM#Hlej6j%SNATbL|8Bs_@1JbcWsun7E&?nw2g${Emg$%8xTOy0v=>#I)G#^+bY~MWP}pvAupb# zng};gf@nV_rC-!8`FDm#a=$z0tX5+!pSJ=|bIEdgH4O)->BmDlZqKAqlo}eP+T=o* zH;9~CP4=Oe`kl1YY#{sPXGx9Ww>Bp_b0|4xC0+HZF0BeDSxhRWZ#med7A#oRZZ*RZX%N9h4+*hVO0a zBQM>DzL8|VH!d_YbfFw+7n3A`-Q8J6>s$PfJD;$|W=G8EstS80-)1L&diCXrpkO!s z4dFHEz$Tl`9&PX53YdOv8H|UBMPKXxJf-5{s>_kwBN-+aCfV{C-V2QS0ww z@_J-|9~BA*5^a5CZxvLvwN740Rvq!S)}N2J$w*O8y*b|>v`n$~f+~}SF+DX4pkCBP zAlRM?8~u}vMMwoALfX&78idbxV<@|6Z#zK^y3RLIY$)&5Y66r1me(fXh-fF1DRcN1BD9+c@3kF?ZcR92tnHdbl<+Z2-j zlV>SVH9Iu+(6yb<=3q*!rCR$BWamT#?^lm6;o@~;^r=pJ*yl@2)y8A*i+dm+Pp{FVVf1RSoai<$E{OP`{j-qnK+N{>HS! z?~e(qd|#4}3I2A}$A*#DRDZO>S zK1rTadd+Z8ztYaSpHpz&PGl&{-{)LYakw+y1xOBxBQ-w9Np&|!pY0gg@7>gxWDSjG zNN+4P@~W-f+2wMLOSXN!eSbeKTsJK}AIq4y{d;`I1i#_MTOBp2+S*vmXAz~k;mcf0 zE>7nfGSdM^l*XnJqgNtIZI^PP-=-8>HS+^XPw8pp@!D{fsi=4HXE?!`6cp=~{2Az9 z`MJk{ZyF-LV_k5fgxgyjBEDLmhe4}5N!|3e^LvPN>uFH7ns9f{4lzV;ap^{}ISnP` z{=;jod~oG~;ul~#_bc9lDm=^Q#*t(+J@6C8{u^$gIYJr_SVTqXT}nnAvyk%Hg*p*C zWyQ?j7e|$s{BQt+F)hMtk2f%#XY!wYGSu6m{RDhR+`Ow;jE<6l^X54Nz+yX7(~=@_ zYaI({zp>B@+{6a$;TAgBR`*(<;!)@3J}wHRK_!Ms8cJ)W&7FC78C)2`=| zJ{|t?zd(O})90hP;pgiJWLVCtrQfsC0}>!>tj2v;JuwT!PqXGc-OI`s%V5L6*d)l3 zj6bQg4&mNlxk^FO&!aoT2KK##unzu4N=PX*MKbFoO3+%k#C2$=p66NcGyL5%f6ZjM zv%Za{^H}VS%gs0n$c~XFJmfetl{y!|x;aZ?=x)JyDjo>26P#%mF-46QlU9-RB}u>n zVHc}lOLN;(d|%cQcR6MyIgK~ zvuT*DW`$>_?zOH?VERwHYhusWT<*B;YY0t|DX^h0I{oZWe-)(Arg)OFp}ZE~l_#K$ zj<@~pkIW3uR3$Ck>p-4l!Qv*fl8KXQF0og_Sq6|#ME?NG(4=%13PXDQn8GKg@Rt}aIPxyA#p(O7M)R-2o56cTbA>TN4D ztQS_Lh+kvpN6*4qILdF`Snf-=ow~D9-2^pW8ohT1jQk#C!PTx z87Vvg-^3fLe+dZ1%=dZWI+Nfn=IB>PFM4!S&c1$%0c>p%*Z!@(gXO8_f%`aa$_JTd z@cM}?)CCCcAWfPt$w^=CbtE@P+~Xl*;so5n^1oiBbiM?uow<48{*nUpz!vIN_`@ro zq(suJ<^gPm_?I_I&bN8c-N_iO_eoGca2#ZJ={-m!>pcKSjk82FRAhrb6to* zXnwlTvloE<Uh$>X$>LPE6Qm%wW=>u|)p)8Wv=z1+C9ERU`6e(f}eeADX zG>%Ci3Z)yTuOt8;kl8G$!OQ?JNP&@y45ZS`>nUo+v|1wA@kq{*&v{jJmM96%tmEnd z{o0AZnZud^!#Y}?&*7o&;Ic7;dZByu;-5gC--JCySMU9B%rV|>S;Ij;P7F2M)}R-| z>$Ij1RyeAkj_QZuh6Bn^U~i8W%}s!&($I*))?XRkjkz-DQ&lZa?isdIg;d6iXG&O8 z;;WWKz!MgfRQCtrZg@)qpZ`vbW>Ve`wfZu?a)a_l4b9LoHI{I56yoWEmf%JU&(@`W zRN*BK4Hs)%K5u>>gUn_LsvuM5z{`-J&_fIdfD+H*1unSkIey07OXzh#QoCmFen6Ef zKP?NEs59JNIZpX}?QeFG?Lxf@=WyDb*&pW;%@mc52TNM=#q9hTV=7~C8(2PV`%T_` zpl?o5z_x#nj`Q}$9xZqf6E?q(1i;&~X@=;kp4HX$nE+F~&NRBzu4WaAKqB2WHsfTc zXZI7Cz4FGH0ybR~h_Ml{I z-(lkn{p!qLWSKGyJq&F{HGY2PtRTQcTXYVYH3}Z5#tCbh4P_ zJTj0C-(2B(bNb;fnbVIc8krrZDsT0tJ8FlPDQ=kMQ-m=lG0?%+JxW1|TW*X;q=Bf2 zczILt>O4nm8}er5miiiD1z0ke4dQq@AWwYH85N|hQ?$l#66@86E63*xwisl~o827w zFvf1Fx>;vl@Tp8N5W|GwGfc3Az|EWlJTCmE64FC&cT4eQpN|^}&uDK~==?U6(MQzt zB3X^WojV$@0#@};PI4pwRPZOlpvn3CItajLj)~xDGl*0)bE!;Xwicrg@|0MvW}ukT zT3^3mI%v~$-J-#YBddEHvJL8KuGd778>M5dQ541Iq4c2zjSKUdPL<`O6-05%fESm@?n3{Yksx*s9yzJmfn$}k;xbDaR;q*)}wdh zw2G9FNnAi}xQ^x`e1B!*ts-YJ4rzX>b*;_)x=W^dvidzn&^d(U|~$ z%2r(~`w(W2E8!|T-x$s-+FUj-ExCVi0!zN(vNe3Kf{A6FG+uUQT5I|vv>}3l9W%^n zB!H7eGO(7g4l+8I?Ogx(46Qk|LNlH3xJI?Cw~?$e2>&Eob2ia~>8-{A$OAyVd$|BB z%yI~Z3H(tkhfVYWIe>#@C7;GGlQ{|206VxF;_~`_YV*@JqBDO2VavOaic2TJu&fW0 z-l?Kq9bH>`3@>5#{qKYmjV^t*j~Uw(;UgF$qx8`@7lyb`bYHTY*BP8&!|Ca; zXq6_HnH!>4$H4U>;f=X|NcNR(Df@%6M_Ahu=Pd=Lcp>+#0L>hfMP+-p;aya+5jux zl*&JYKFAL+!}rI+qhz07aui~=>-oXk0ksYUZ*fzRoOVA$^Tvy2tbyjT<_mBXs4XYJ z*Qe2|g{{${NL|JV^>pR|+xCrR>P&~R!1x9=c>+T-*yJ1f**-S!c%C4X3}h zRUH~F^1Y}&18%cL4!3T z+hR6~>K2c*aNI^rAJ^i>$JCPaAXR|4uEc8Q(R`e^Gbfw1oUOnPsAlyFV}0XhHYp9Q z{Ovg5A`WyYu|T*KALhY;LpNm`O0ST*<1+bjKY7!BB;W3R)uk77Q&;d~$4t{}PZJbB za*oOs0N>NfN#d1JyU9l5_F(Es0TZS^aN}9r?V~G3cK6StKTA_N?^Q7Q)}1R8A40s= zi90UGyvp2@haO>{#$uxoRh-8JDydxIYgbZbe_Uf5_S!(O`r3Wro|{uyCb!g~%u3|5 zA)V4K#_ekV9dYq4r|ZH!;wYB>Td|Y(c}J6PM5m~90f*aH1dmO5gDonHQD}Jrc>osd^3{EzREunYizuug*LLShez+vsF5IcI@Zx zJYM(y?|l4ypwx_aDBMCj$J|1lOOtj>x-BG&xx{B#%zpQZPJ0^nmj}9W4@+M5ffu2 zLz##6C)U%6PfF%H3xu#*tNrC;B_9_tTtyd}O_k}u#nDbdPeK5k3oK+no;Xc2mGZUf zOXXJxT41dq9t9YVF-M22@PEiS>zfE7yh>rb&Rm1Oq~mp?(<*Zf5KX%4?5RMDHTRC5 z5$N3|UA>Ea?wi@|;644Q@9=LM5_p8kmQ9BNe@v=rLxx11KYkig{`yA$7SBjn8-@Sz z8N)?c(;h~qyia~BJptDB*eT9tjq^O0kWO9cDU3XNH2rnsQ$;*eu2P(4*mUhZ6vJQg zFmt$&Mi}l%<(NFY_#cZ`&%n`)ZzRI`unh|tqXE<}u$JRxpzm+}YY1aIwDLkvwLOcA z-MU_vd>Ry@OdCG|yH3V4nLinbIBcq`Nc*EF^H+KIoCJk^?W%9YoOQSs1eE3~Qno4b znvwV=!=#<=fp!Kl8s0ciloUh3s(kDVz_7DN27*v2Z+J0ZSYDO6s_Gt|-~#=Jz=Ix*{P3re6atXOcg#!1|@jIZo16UrQ1 zXhB@rBQ_@G;J3}bvJHv&p0hx!%Toy9+^<`zjizgB?V}$cK7BS92 ze^$%`0v=t7{Rof+F=^A~66~_15dC6RT@Rhvl>F$F zypj^M&yYIii>^HPW#U?jCM~zNOl4eO1<3r!nW+ynURvbXqOT`fnc!3>H{T{3@JP=l zWd$klda@%nWi_xNxk@QVI#!RX$F}lRUz;AFUzf7SXdKzCMLlPJ80;TaD5+!+MPji46?54)QK7~B0=}>(rfnWyj1+?kX zUc=|||J)x*+n}zbMrCPo=<@yiP)xr1{VP5884BQ7wC~N>TC0^Pts{PE9tS|MMO(T^ zTJzdxQneahSl*HvqTbx&f>U~<{KIYwHhqt*P~hv2=)p+TR$7dnZwjJ(YCS48_ee9% z#WfYmderseeOFA1BYxDKbp+ev77wnd2uf@JDR#u6oL3C=B{9=kO@^tS?zU)I_OCP^ zmw8!uzem`&VP@@XPh5yP5qAu3a0qP%bl3h@Xuu_^jl-NY#IZ^I1fO3&+0A^7orly* z+v6ft4&RR8@UdJ&`_*empbnk;MN2OJ95-FNvtX%ouEV$_wCU{Ae|xcIJt6)UkOKk((Zi$*NMbU-J$S^OGI9Ar zmiGv|d$MK%?8O-U;|dwz6w_w>1?V;4+vmxj@;hZc{e971R=kNW&96ab5A~naD)B@s z?fm3`c=Q|4p2$7^=pKyZ=;-S_e?{*R#CXh!JmuEb7X0Q5*tp;_Mfm4490Z0dc5;O; za(}pH1x&N@_R0kVeC>8GT3~fT@^L;gxrm3Y`&bK7%nxgH)6kV)s;eA#{ z93M*G{*vPnVfbMJn*Ecx$IiugTVkcrk5~|hYYrs|tZZ|&C_|uUduFYr^Uf{l{`(cs z^=BoNlqP@$`%#tPwG!d5*^8t1x7#hAQm%s91`%Kjc@;WE2xEZoqlNd+Ce}J0rE)%x zuF`Z?1|;7MaSvtyuT*|GU5^99UnM<(eEuSRER-^p>|jjFo$0U{w4XXo^dM|f7lWw! z_L%Uoc6vG43xTbZH0FjHo-V|%_3&vRrv{L20oCDvr+fdqb6T*`i`EsRg%R=JPqw-) zMmZSglbt;J0zf-b>52|$$xWMdWU!SAY10q>CBLJS^hMB_>DQb=IyBNe$ufGYQ&T?j zqwf0|U|QK88QF%ie~H={xW>lDuImrG0x-mFGRBftM;219b7zEWokyXTgY~0a4bJI? zr+7zjAt6)?le}WqHQH$7PRP0=4s@;=4 zD(TduM^2+BBi9Nz;$C<-C3B4788(M26kb$rSp%CT%2o2F;U!BgeSjFx; zJYH_jgpI<^nNYR0f#!vt{&RH(jwtiyz#Ngi!4DiE(kOw|?9Xc6$@Mv~Sp$RUo`3PL zMcKUI-rdr^w~GAqW_v$wZ{{xKZaBng!a)3pwQlfy@_R8(K+Ef6<)-aPXZm@;$kZ{D zms#Kf!im#%_H))q6*p~oz^5fzk~>2r4u*12?TkLLmo%80K7=(tlB|VYk{AYeOxMg= zVUD7w{^DShvQN$uI3*LfCp)%noN0X3kMD6l4$Knd8NN=Yl75P3$?|f2C)(O64{k73 zANFjo{~!c&>QY ztSa1l(r0k}4oOs_N2Z-%HR#$LO;Z@D6@?7NKPWFhK@hD2Ta5?8$pUGk0lv0{-pvJT zYo+q1C+)-dw?q$o&5xP?F+JCZB79Qq;l4~ajtCKJx7r7H0w+_JbEmir;?Jca#JUMH zLEX7;(jG_pN&z3P#IKB+ZBBT*r)?|UUg>+vn4_sx2 z0x_+U|6WwO+GA#WWk4+-2hv+nBy}B7yzT~@E-xG522=2O>xJ>PrUk7dRBoefp|>@F zx}PJ!RPV?}wqO$JmNlB`@A5Ii8ba54zqY;xI4?6f2)pb6aD;oDl*L{-;3!L$f@D!v99r3V+Ns*FJ?{8yPo8 zt>rMlkzm^yXtD%ZDi3ArhY6fHjq5bFJZ)=pD@W~G)sRp#+p8}Tc)_IaadJGR38_I; z@Xm3xT%2NNnx4Vb-#g{BLWKWlyJH2pCSEJnfAx*E%KrPrPG6FY$US)ioPbPyEY%L$ z06j5MnsQU+-kN=lGsy6n=%KJVzS{J1Hsny^TV0^hi37TmX{ZOlnfY zYw(_1o@o;!8PxEsMr8g0%D;`*<_Zard$PEgbL0!NE$F>XMJMTz&a+z;LGGS_55<-q z%7)SREeJ;k268BuN=V1lk9`25xvsfU%=U{*usJ}sjU23W=uxcH!&9#e{uQolfFmD4 z@7x`TpHs|u_+ghK-8(aZIm0YHJYLQ%-&KD$dm(5fzy+I)liyq$!vq&u(u^cOuK05@ zJ{Iv`ixNRe7dD?E9;)7Y6I|YGTNYp)r@9ck70sNegFkN07i9!%jqKJ0nd%O8AaHf< zbe@6#G_(+*-(f4Coqg@KnIwV|S65Ues=fD+;+Wu1jPBP7PMx{YdG-iZB;OYR^^}>C z1|O$@VgnxspYyD{$|1AW5L#3MJnNWi!BUbrY*IcA$@uHvm*mB6Q^ppFdj7T?l)L}e zcBvCl)4oU0su)-CC$*AdfeOEgAxZ1V0mkDh{&EjNfs_K=HbEq^_;={R5#%VK+|Y`2 ziNqpjcels^)xLvK8#x&XJSJ*m;?E~;X?#!k?FA+5DBn2)q;S{OWRc3;4=HG}nK@?? z;E$M&bREVZzVNn5&fh?}cILZzGRob)bTp%5+tQyzev{V8abjY_p<2)@otgP)Fqo_% z3*@51PmiJ33t%}4q{577Fyq8pTzmb2BkP8~@L(EtGgKe-)4M-(#|Guge>sF0wZTCu z1C#rNDWNW;fvJ$#{E2&d09FU_WAHuj@Hx6Gj2W(wF&ua7=Be8IbDZknd+A1YlvL|E zI(V;b^v)&fPoBb`-%`*-uSz@o5-|rCS^Y@l-&skl6iqs0hJ14L{g|q33`(7LPz6RE z`0($DzTH`13;x5L?PvmOB^6RRlvFk))?ZZNyfxMS{==ea&P9P7&?J#yOvVj9#j}V9 zOaQ>*;Q$_{PS7b{!J$b?FpIXNULLfh9BJ-Y{nRSH%ct z@IYPv72cMkn}h50C~q}Y%e9|iA=f2~-XthhH8Bp2rWGG0lMJN*wq}~>Qh+H44$iZR zSikNwYf|@R6`@z>THP~~Ud2p^$_>k)d^D(8DwU`ru2L#6={2EC#39e;4O6Douj*5q zknr;=ENXiRgJL*2tS!<=y1Q6W&2`*1S}H~Aj|og->FJg*bCUuCX=T|`Qz44^kKoK= zVh4og3gA*mITM*8G9e9d%0+}+pF!n31BNtFR4|(m8RD}(0|CqqGS+gt;LtM( zN@kF@$aJZ7IpPv1cFC}n%$%%r*KEM5H;4#)f>_$0YdqtT(|`RDB^hc&(q9c4yPE#7 zjPw=mn^*OhbU773Xt4ye=h<%|Ntx^pl`0$S?& z=>?o?7SktXScHr}g%8zjPXb%q#N0P$5-FI<*?}v*gR55sn3#2d)kc%LL79n1Ehpv8^o#>SJ#%gduK zrK{EPxx3ul2&kGDDpDs2%s-WK7j?!OIrea7&p4&@~hKb@1q= zA+k5?hQY$x)@#NqXW}|ReUcrtBqRKM_Uk#qB8K2`hYMkP5p*U{NnjeEf#GE0aVntw z=r`=8?9Xl4h4KZ(B}%3Ze>UY7nEP>I2glDFhN|ulgx}}qmzvHoKqLA5`^|z))XGCZ z7a?>_U~1ZAsu(K4?CI~9x=ly_qNBQ7TNc(nA@9(G?=oUaY(Jb?qP&-Uqx{V%Utw+c&HUgTBPemmYWt3SxGm5aU0xb`RKFB@i#19lU z^#rK~zV~y>S>yOP4}ZO?Q_mGWpKn9YnR>YpG#laFeb2cZ@U_^}FYofJ{^9p0|1Q|K z`NDc=a!31Xe*dE9`1*l=>-IvL;7}U?4@h1xu=>a~_5Evc9AaQl29KDc0@heoAl6av zE+;4aVc{`sQ0JaK%2mraJIcCE;E8?x7)l0RPdiQ%Pw9v?$k=k;{6&HnVfZwK!Cdb7 zJfC@X7%qE#%Nr2!Bqm4FYYe-?k=caZPVdT7bA9~hoyO1&rOc7dna*r@JR3Ep`!?E* zp8oI%|HK0oa_LkKy^`uXLf#1k<&Ly*0hPLmbLH$i0$N9P&$vP!frdTt1pg!&-%g$T z0(SCbOPau2(_^-RoG03UASbFsz@BU5E54$4$)|f4tg;Vr*z%x7s49gQCI z-GF>vyO#cQ`3w=`#K?3kbRK;oO+UuwcWF^+wAn*6{m;Ch^O?JEww+u{U(@u?gEIMS z7<}PmXCXuOuVrzmQ=Uqm=UQe`Oo$^^NPR7L49-St$trbL(UP2ygdAW5st}GmY$@sh zP?J@uny@AD6}ad8IOhNfD1L)Brh@*XZfy>>dEW)3o1^4da8fhl!#zR1(@T)OBIarE z7wq>c&jW#EE?&e*6QU0HX*3ZkWX!y%%>5EhhJfvdm3LwBI7FBOiBbrl+~=q2w__W< z?FU~k_6V`(oZDyd5#)1}I!(eoM$$iPXU-2L@>3OZ;J~JsWRg5iLE1gp(cbffkuOrpW0`{zf>`JiIp>Z(p{HtjoA{!7>Lg zCGWr@TU#?;129lGPCDxX!alc!ho1ym&N7|7RODs2sfD$*9eMyMk+f2zC!U<=;f^ya zDT)+*D#zq=pZk1E*#H}YdO{dRR#S)ZYouXJt6UEu-QAycu$O;Xobuq1N@=zZ z;`U8~$t>&QdhszvntA04`iF=rJl<7!-b(Rk=*;r8E18pHAuQZ(5J-}7dJim}`P80M zP14TWIH~FQ7Igp2=10`gMwbEm7cgw-;^c?R+oC1D-e4S{K3cUfymAUdu)CvZDGkBM zgMGyHY)XrvjyOl<3B*|c4M>Ow6zf=4-A5S(fO3z^O8uEKrC}|n$%o5D1}j6TZTa&cY@PL z+S(79hN54=mJONzQcNtr@F(Lqrk-O>5S^{?B5bj2rtS%Wd5Dx1V~Yt}1IX@N(drhL zDRxjH&njn(*Gsw01ro91z;rEJjHLSaU~&|b0+p6Zi+|?>C(?IbMlLyOEJ2L;Cjv(j zO*`w5*ywY~qnZzk>!E@M_mzKO4ObCe%i>AZ!8P3$G==pCrV z9E-M(T*xR6Ezyn=(+i4M%^qBNVjWcIU0xDuJOS9Ec|eVA`+=Bs2UfSv;d0p<9pC|m z2zW#l&bF+eSx?>8K=eQY+lQ+6ctTcdHscT~JiOYtrZuTrn~ecyplIZ`t3r7&=tLu`03quw)3>@NG3K*LVf#=_B8ELqRuPODqR zZU{4xqWVm>IJZ|ZPn1!pSHE`i0IbPU%^RfA%wf2#N_1k*6Po*y`Fp`o}fF$ zn3Q5o_6j67J(pJj$ObqsVxIyfC{kiZY5NZgP>``U!Ork?4vwFbN6 zQ>?#i9)gjaz7E;(+`NLIEL^ufnN^%;)SP#;{`4HsXvrTn7Yt-`+m!|8_{f!068WmA zAoC1kc}&m5Cr-F>{>cSAck@zYoL_We<(R@R>fsKT@|LjRN2g+{1hh#NXR$}q zdC?)TgcnPT6yDk?_tDJI*?UK6?I=AIt>+DZU%isMXk&zo4?=5wpVmsB(FWilA4l2ql$csHb3wTS|{(i9|Z$I?K(k)=mW@AbA zqwcmsYQ&*d#gTP9U~+prHL*tWZjU7|(DLCqz`?R~??wG(Kk7myMs4Sd>kYp}CUABL z>T!l}WGFfshZK(@W4KwBA#0NqPxG?fHJ@tsS6Y|OiGa{Ac_QR5kxNQPD>MxSmMS*- zyp9;A1}8n^0GyG-VWxyzdnRd@)HROWm`F(N_&#}o(dT;a|4cLf4|@M?wd}M81PI6< z3&XOr3(6in(inN$=cCtWD^2W1!SL(H9UL2iK4moo1r4SS z#GQZ}Y2nb(iJgesBYEOn-T_YZM~pjR<@z;mDa^f4rrClHk#+%UIPtijj9Ba)cd!7> z#p!zHCrFeps_t}sGd7eWyBtBDQ*Uma%XAsyo+KRWV7H3a+eIGo-0d0C99B>#lG&{b zw63_GV&1S^+mGuP|9t6e* zESLD~D3t-DlEd~?_BsRs;kto-_^!gsf11U_fIJqOY=Zk`bE-k_diQJ^7b-%x_C9;c>vqtW0UL_Vp+CJ5P-h{^8& z5PJ(q&LOUfm3Q@#=uIe{3y&--sRg&!qS>!HmYDR=ve?Yl@nK*`c4$M<(t%SSOe$?w%&O=*wvX!%vwvz# zDYF(*irKii)YF5dgvTAwuQb+ar1o)*1^3RI7H6V-824Ji!J! zrL+|(EZ)wD)rU-Xigf`GNZlegU}KX<)%}He#`!NH`ahzNh0-<||0j9~a3CPK|B7Bo zR8U0rf7QH=%B1ZE17g<&4LawrIWYnBW4tozC|op`+&M(#wvaMS6qG2k_I&JjkMsoF z{2vOaeMeVU)8A-3F9prVG`L;%@VqR`!sbZVWe=83<-T>fRY#W4J2eQpnD#`h0H4jt-swvixm3P-K<_6h~yDBLS~w*E}0!OQAt+L}4QC0E(=>6wv0s5u9q zft_pn-;PWm2Ioc*Ox*du-K+a;^%Mb80#>D5kG%5rF;XjF7-VZv%4e#8{dS&vf5_$2 z@6Bif{E#U$CzE|{1$kiZ5qh?&bA!yVjW$iNsd))2?B*z4uwfgUBz{++mWf?f&g4qP z`#fMQ5|_3tH5$ypF3(zWe*ZF0X*4_nB<;rM1jIinLW93ysBvbAsnpp>01D(UmY4{1 zmWzkM6tp^iisZ2{UTspW1kv#=_!53hh@`!CNWsYxLz%W8!F|6vilMUm7gjFG)$U0L z9>>GiCsqrfg1{v2>~qFFaNKNcU*`*5>C5&2w~uG{u)Nf)-!Tr#ExUdRlN)A9u0h z7G#LKQA0GYI{3KaOI9CsUM_3S`ZI8OPsDE*GIun69Thm(?*7i2x6OYD&L7x7p7(aV1##3a2E1M{5h1g)Y3?F8-knC!1{ndO7~M;Hee zH@JC4NPAevM;AB;xW+~$$i{j&*Cz)Tcn6mV2%M{{vy(yt^Xl=V^OM5esK0V_bpH?h zy}-3th&K@ksHqaM0Y<*L#(jdZ`SgmNZlzSB4%1Y&lOcViEo>t-4b4qPN=Z=9PABr$+!TQ? zqVr$d>9VA(H-_7{7V|AG!_83wzR#E4pFX4jlG?JM@uy8Bx7c(*5|#HPBK#iz7G{4@ z5+7_w4(Go(&hJ@n4i1hNh(VwcIkBYv82ZJ<*S}AHA3d3Zw3=9aQ;AU>lE)aL^oEIL z?}=gdW=g_M(lLmCHpr)p>6SG-2_{qABO=QXcoo}8d62}1t00p~{1e{gL952_-syBO z6f=Vv|2ApbL2E#u4qTluL=6}d4O7!Lo|Z|!#)h6K+r8sSvfUs1#@Rmaw)TVF=(=># zAy)mQT+j6CeZbnCdlfA&F`VYf%5M~gO!9-gBjUxr%M{c6d|Vl?=RwV7fi=A?g4#X~ zkG+^WF@7A3WW6&Kx-owpM@8-7x`X4Mc{$B|s_F&a8cdmU{OAT|kw}AFeAP7EO8A}s z4dXRl*FTRLWdJrf+nS=MP$r@qB$Y>r2T}XH<|<@`5!3Ai95GG#jd8dRrO?pP!~wj z7r84gF-)42F~0pXbrCkpuK;9CBgUU z7oBS|;E!Ifq(B^ph)1ZRzN|?H?Jg3dCq|QT$RG|cMSZQO$UBPvB~&y5>Vop)9$H|L z8U-Vsy$~bqUjdX79}qcibeBw1qo%)^h@k;pB~^SZDp~MSRiokeb$>I2Ww>(xWGNsY z&ktTxFEQMWdQSl<@o5RJ-|2{%!!P2v)&hTLKkbyhun@eF^RVRdR0;PNa3Qh_*#yX8>XIrQS~A4z{r*_*f+1c4Zj@>=(1Rf_ zyb5!ifbQg|v~)^WQ3B3x94Ff9uFB~1T zck}$uuo9ojm?QncBRF9Dki(=cZ`Hrq&kb;n4YDOj4x4N$zol3qVmzZNoLrB1W2578Lj#^E~^=oQB>2@a!S{vNVn~n8y-`5MoS=qEM4L z>aZW4f_WF$lZ)fpsvDh}RZHHOSFfHo2~Ld4j7UoS018VS!}!HPil*_7`^&;6G(jnZ zTwlSd#^=@^y{B@v%4OEoidwc$5-&y=kr11QQoIQ)6iadlm9(Acw3htE28N`2w|>EO z3U^wE#+Gw-M>oY>o^WKty6%WT{3xa0lq{}kNf0rnya7BeIKvuX0C#_?g&Y`4Zk+`y3(;PV zaChT610)O*EDl}%_wT`#6id8^$A~8fXPlHF!pM(*(~YLep0w(BNhI3TLMGQ*7h6@Mw@U@`WqG z3_B0D=5X=VMwCo7GTY&ZCgA6QI3NN?0*l%!gSFuNTj(G?hC;TM?D)^19KL%fAQ1gq zagHH|Cls)d7QoB*p;Koav{zh4oa6i;g7oopLZj|3_>=-%(&8xpa)qb}Qcaj+DYNu1 z<0B!~h;%FqnqSJ6!+O6A4kzKqYT}-XrmkXhkB)&nFk_8~8)v6Qj#JYqJg0M7qMhss z4^Nz!><-u>^hzn&D~~WO)=C9F5Dpp+Hs~3YRS9)2@LhzXpDG;Ly|e{vpiI&065nPY z6_TWgeF?~i#{%$}ybJMhxV1a+iSG4IB+gCLgVz~(i_MoDP}QqL$9!2}Ypq}YvAniQ zqg{_@uKHRoNe9SVKp7HgBC5msP_~BWCuoE7PZV^s46A4dC_$G~j38m3VTcZ62owLF z$62Pn(Nzu5|xVSjXcU9&ID>0 zaRf18Xw>Ln@!vk)p9nQt2XXjc$W6#Bvhhd~)sFw+LoAG_9{NhQ_fO|mrB}p+>ZE;dz>I~4HB6K;T|R^I_8g2UWF@L^UxHqp634=8h?Eb&Hda2yB$WwVQ58G=V#;BQwJ2(Ax__9?_ZA6}V%`_^ zM|&Hl&7A}tNNL1D+AT%+l4J-&8C(aCY%*}&fC}XMIy|B=EF`nbmK4k}VBaPwu<95c zK&&$KcSo=QeQ|_W{gfJe#-O*>8WYlB4g@2^M1TT91bsOhqnjhE%IfgvEC;Z0)_|%~ ziB4g=L>apI(O{)@WQZ&7!cnkSMfo`^3=S~1w~{`^cWl!aB;zJ5HMGG)RSyW7Xb5H{ zZURG3GIa*IB{qC!Oh{%`Ed5+;cv@Wyhm51OP>^;8G(!SCRcvTC+)7j17HPibDrZkq zIB1Xj0qBJ{O>DhR+y4H1Gu7Wwra}m${T6^emPCP3$XvJ~XcW#dRFY)wXu7nK0+s&* zV?dn0qNq$l5S3U>JX{k-+->+8WZ}#n_43u@%>tyd$^mfpfJ$&y@Ap=HxXj(G&d*xG z0mcU$P{yxKtlFKJ6in6D)Sic(Q!Nz_Q_`BF-{;7dQcr90LAf{@QwUs3&yG-Fb~Ccmf4WtVvPmsD|-a_c#kCG?gOwFk`2hXD>gxw`u11>2=yWEQY2F) zE`$Qh4XN}>8-WK0-Cu3P5%G=#P+W>x^S@twy!w z*>4XT;zJqm4P7G~Nm0LGWcr@((iE``pAxl?HBehL2xyAcmS`lIWqaUK8( zB%z><8G9N*mJSSWOfe~hSq#BZ4j5PqUOHMFS*;b28Y5Bgpo=J1u{aDfvob7ILbO4M z!|V}4d6OpT*gD@Vo;V?bh}b=3I93!?l`$7{;rf5LqO*+ynoQeBD)QjICq&R02a!6f z0P*FGc6%*{H_aHQCgZZlZL5MR?t&Q+*&~3T|Fr^W-wFKxBZB{z*^m1}@@KeO$KdXB z)hF`;|6pxpp`?jBHTF02x*&hxMZ+s~KU=K#CzS1CFjT?w0 z4RhwQ7J1e-MNL7(8ZfDZD=ZXYg2S(huP__fWWcEi3kmS--iR6qRFqx8;w9b0O9E^P zuK)hle#WP=j>y%+PZ<3g^sV@tDl6`W>@w+xeBC$fq+uA!7&Q#-8T+Yy_GKI4FYiY9 zbNlQwjNY+3xhpEN`v&^Iwa>6f*)lx^IyNv6_AlW}`wZBRh!WT>QYTJ%?^j|8nOC{*R3*FV_2#2K`U|_1fvbm!s;4k9M(mo9p52>OFq;o5~RHjf`R!|$zG;`vzese%A(E6P+uqYD`n}n*D z_IekF?&)HK7RU7b05_@XhhgGoVOD2#ie-nQ#)FDwm|%0QtTa(DEkdvuVilo5!CoL;Ix92Dtde>1ocwBNbI+gAxcz(%odQx;@GD!TOJkZ5qQ-l#6NPup@iAd zY0`O}@~bAO9mn3VF@G!0L_>R5L%z%XT`+7F{xlt4jax+6saGpIufnCoLIJ6ZJM!J* zcP&bh^nHsOUSsc&YE1h}sCBndn{fT;uXJ7Ap+>5M64eGGykBo0vILF_1|O@?=tsIt zOU*TUZ{Q&gAL-l$EdCgEreklsqL`hcHr;+lgMcF3GPjJtz!zXDxf|39gNlK*x%62O z5@JTzID7A_-1^wq(FrCPijV85^OntDZ6FseftyNannNw*$vFR?l7XZq7dKo@K2 zi4OnrT7L}H*dElLoPt9m%{5eVL;^&02e3U6+TwgG;;^ED`N0Mh-~s#o(1XNMZA}gz zwsEur&|+`eEh~Fd%_~1^`0`kY^LL)}XsRwSkHHrf)c(zO`B^e@rnjpJyABAdt;=~w za_qV#aFhN$o!8{xno@kcAbcUQ0w^{W)87g5Xa^eklIbeNzEY;>p+rxNOe?mT14u(A_Z>^?N+wZP|YpA zspMVNJbZ2J664Y|nx1EtQmiSVNicKU*Hz%M9QaW@rJKhm(_FyyhoLUZnqxoV z5eSU=DC`pHVzJ3gTS!B@kh;*F_HR)&xT#omFgxmQ(=d9N&urOFlr;}jC(>}US)~iL zX4R%)wWc`a3|RQJ#KT+4Su~zmQnOSX@NSOMGYJEZV$Z)7=9ZufAy7Npq;C4J&W~?Rcs-50-K_K-lo-#?Ba#>_A zxSI12xOlGRBffP=EN|A~QG%%%+vc4pq`Cc`Me58P4YHWiJ-ZKdnaXURl!p1HtM6|O z2GXdLT6=NqR&jiH5xaWroHVgbLye||DO*%B{XOku)vL}f)^zUbv!~28QmA?eZ}Gpc z&{e(IT~m6ll9=#5eJ*SNdxWQQncR8bp`o{cK+LO7sPZB};my%9eLUn%a%9pRc*CPO zXauNLPE`XM%tz&-O#r!wshG2SM5<{!s(Rg*TPD5f#p4DXO?}0Dl2fm^zCH^aZ}W)pJ*@fb zpI`I;G^fWQ&=URS0tEb;P3+3vq0{Y%R_E&}7Pi-GS9}FBbu3)2u8+^+R7v27`AfRR z;0BNKeg*>>dt(cPIk?I^R9ggqO>MEW^r3hGC@6R9LQ=N{EU(M&^-ym=nbF3S-v_VW z8GF4;e8a}xu*K%>+zT44jqZ|#qD%BpZmNKcKY@B^GQc{L2zoP z0_g?Xzzky7XhC~YR7;2!n6KSV)zLv1{#)mio0%a}lDY$6v%u0hH&s&ue$I9{lh1TG z3L%Jp6VuzCfpdyzm}L;6vPvQIZ`1qvrnfDB7Q9#1!WNMnv;ZF4{pe_!dU;b`}f9@RPa%oB$efy0LnpTGJ z-#E~$4+j2r3`qB{v64?1F2EhpHU%znX71OAb&o$I+oqD&LW_LD3bAnrxzru}C09D9 zz?BmmwgNA*x24c7|i{FKjk=3z3a!k_-CNs<`bx=>o2k?kBjTK0hyNo@u713hTT4uyumdx82@hW zPXllCC)G@86azUx4Xdb@6~k@#3=yFiT($Zsy+k$QQFYm=svi+`KbNp)!+2trM&4o2a}k0<6rk zOa!#kR1j>Hf7f6*ybvwIMoR=_NGwaOPi^%KV|ymt3lDH})m`8`+^aT(8Kiqpa`A%` zBd$o8Gz;_nauXE$zU$SJ5;2vOf2!a)9tN$z(FgR~Tu(Y~i}|HrZJa<4;)|Bz+sD@M zwEeLy8lLEuPk_8yA33Q!;@KbhRC#1jd4#$@l-+H8QVz zD9q^fM!xe={Hl)?95Aqt>iuM5d;{z_*KcI`8g_+pnK zNGbp|!MCdQ#RWKe9=^&17(L$M@|&#FBh_Yr7|w(j z2#R1o>b&8QVZGlPfcFOUQ6xL+4#x^eJMaczCj$*A=#XJh-?2RGZxo_PWKdJR=&u~*I;61q%gD~zMVA~H&srsjqN8iRZ;k`rx>x}yEM4JFPh$%)42D&iYg(A@^JVz`|9L5wA1&=6R- z1UQ7kX}fY*RGudti=1_FdZwvRR9b^hB~}sZVKq-bouLRoX}&;IE4i=WgBVCkRH0wG zDFmg9Vkrg%Ig^Ri1vUlWUQXf#VY^@K4}vnC$lzP-SxpyKcyQfKomkBWBbThWb0$Y) zi@>BcT=z80qCHAhQcHB3E@mt`YGBsF;TDWxG8C}b8~yx~cB{yN#F7kAa3AxKi4l(7 zJUknU$q=`?mysc!g&sWPHAL+mc&}Wr{fja#nnXArGFH||Vl!;qD2(%x0S~?riaJ)< zK-@q(v=jTS$tb!d>8cA#x5L_V(Ll|T$ZlOgmRnNR|&Nns2Gs+99g#WcyF zL;~6xIJ0S!3?A61p(D6BHP7OxqPP>-PD17t6gxCEpv9?q7Uxt}cB+6pW04RtqqsvE zB_HAF8o)qkbS&Q3r<@8TAEuw@AD%ym6$+XN8^-}^4KxuQR`l&x>)cmLIZ?$%eC)Me zB`4UZ)bBdGW<0=ob%v9|pd9T7Ftf{2#4-2G*VsnWRiZLi2uy{*Qvq>%G$6hXppYm& z9w4nCuzARq1<`ThO~fxQo#&bsVm}d6r14;n76E%24fejOGqsANoWqdH2LfCO88-PHq_817ifG`Hz}&R1fcB!T?4}SQz}ff-KhPp4f5%Am*nk1P z>;YHU+Y1$SF+=NOTpBzW6|+aaLnRO?D72mo!570Vq3GUu5DE;EfR@4ifC8_(!y6YO zqJ;QXJvD*Yoex?D%TbKcIelu?ArfUf7_v6Ey%D#yj#}!)9EApmfZ zZ3JPC5h%hgf&_8~ihm!tTieDljZ~Bx097XAaxa0zO9z_?ufg3dm#cf)acjShsSyj| zr$&aU3^eD#RXmLG6g}o!*mUrsfPc#t&5jh!MuJg%i4SPMVM~b}qS%u1$K?}Iu{fF$5#dswKa|T!exd>Ja97o_sy_zJUCf+rN5S$=SYCWreLZXhL$X8zS=^L#R07< zX7j3=&XX8@9g&>}_zhE5$>YrCQ>Kl*Y;pG`MS6}M4Z%YAEXH&M=h_wNz)y?28X@8$uSR`DA#59QpM~o^ zYGR+{=3-IzVJ)as2k6f}7jPtDI(7m?(yM~^eSHq(Ca8q*t+(Z2Q__tWif-D;NKV9g z6Ec{@Sr9A-Nk5MybrS0AlT;CydBVmi3*oVNyofd|o81yf`pM_1SSumf zMsK>-a4ZtI$3xv0t&?#mtjBWbm=)}r~o)Rpfg-6x+J0+)uS;mx9>;8yc z4tAF1)GXyH`_|RVkzE1L$bOEXGMY_O1SoV(G*?rA?0|+VE!7^GK(2Sl>url`HUM2= zXNxF)OQTj&4K^+O3X7tUUXStQru5NGp)DMK!(Dj5WFJog!MJcy z+`B1U0I~O>?C8Xp@u&jX@kS@{vKJ()TqHK299E6tjV=y8Tt~28pp-H?*^?r~1#Pj5 zD=j!&=pO{;TGdof7#j5Fti^VXMyI;xwv9tUYek}E=fjAAo+*Oru{VgWqBKU?SlpB* zC*R1PJQmSr1z!OPpi3pjUE--Ojv>O8yF|$COAyjZUM5DN8bL#ZZUmuNuR0|xGJ&J^ zJ$F9W7Yc>qZ(iXW0M_31MZ)Gw$Of;kFZNy`#?W6M;F{a8=7Q$~4M+^yhmQC7InJS( zV-BtidBLkI(w8?p_!^=rwJaGfk?xo;{SjtdV(QuH2pO%Y_{`sIIvp^9V(Yp?xr+Jg z1ZcUE^FG`z1CC}K4AO)+wRFkwh>v`bqoI_aIOBkc)vEr3huZ>S%qGRON0fKVp6o;O)tMp8PJlTN3k+mh@pC6k-Vsx;+$v>X-Ng))G_{tw_RjMNt= z`0N%PjLv}#2$g+HY|p+WGq;%L;&;t3xyMOS=jM?4IQae`8iq_(j`aHsg)=+p2O^=& z*%GgzF5egM!bK77DwWt(5l$BquZM>RQd}`fIXr1K5*4MZdE(SvmV^Csbv?1cVITE$Kd6!fnlcy<2gzAW5_hod5mT&cmKR=zMI>q;{I#;e!{C|ft z{5N{IhcJlNJ>CE%3hi?d|9Xe?dKelA5wk}sjH`rSWS|^vUIj{N`t`Y$@8ng!=XjOx z=u!Ry9LWhcB^nw-;@5bRr?`-}c;L#D{Iu1!9LUKrd@}4Qk8m@BN&o8K_{j3&F%IGv zF|Tm^(M~?^X+aet{q&;O3E!GMeZ~!+VVSL_&l*%mJ>$HcEV`IoG=34IW2B7Crm1lMU2}= z*Ud3LmKhcMJpqXKT8==bW@(?mE?1lPOEwwa&nOM-TF07->$WjREpucuwyY@5QAI0$ zc;^(ol;G$a?^h;x$}P4PbBn!9@rSj0CMN0VbOY`dzXp<^OPZ`mxaTZh9YHA9GgS8Y zjUp^b`VX8#8r$RpwqyaxDRYl;gDaf`wUko`?WLk@MdxIIHY`;gk7igS1O7n54yAUs z4j@}s+P)qnR^HNjR-5vBsy~-^Zm7xFu}RBzqSmmHmsnt-(hdToo0v4uJI9+6yy=IW z1LxFoT+)7Ha+N(sTA^$;n7CJF-DS_;K<2?& zM(Qw*e_a)#qV{{MaqiH+Yoh1QL7riaz zkArX^QYd+kN_b!zHY@Gz7LhKwb zB@VCi93=7O5F&LcF5A*GD0@33eM_ipIie+vlA{!Cp_t5`6&aP-I}fYd&hy}d9m#{Qco0pM0{rwa;X@}>CZl&oc^Z$ zO190XZAIjd2Qyqau6p{TBr8(ylmN7UE58&yXkmWFog}3;7{)22uXs$ZB^lNAGxKW; z$ur@%(>2Hcq5xhgqP1*=Oh8JEcjd0iU^uCeM?9*WawEsoPA-jB1x2VVZ%{Nd=*O-g z`1B?2Bmg_d3BZ%#j2CnAB+_i1`HyCIbJT&+iPr7Jv?)C|ysT57GSY#y=7*tAC5kvY z1O*(AyMq2cQmM_5D{R)Y#|MwQgI8&`4!&`CeRtzaHv}9!dKY-9re^z!-%Flgoaso{ zGw1hVQnuA+<+;4KbRIaeEb_!zy1_h~#5^z~hr0%i6w)tGwrPr<3F_GyrneucgMaJT z-yHha;}Z#ep2%-7DHSFLPWr20gvyGIzlrq*3|7_jGg-^0awQm|Jhx60=j?58VO?n9 zV`uAtR-Rq^TpOgH2TK)+vvIqJDCP`lw||i8r@}&mxhUdOA8Z&s&Kv?fsG&9;lE;

oFa~~_`m0mfZ6Jd{IbMyeE@Vt&e5EFc43f9%^-E?)&N&GOG znUBpwE3ncjx8>AWlwVBp#A<`NB6Lzf4(YdWEho=U_ft+SiqtbsI=xHl8chm=n%Dg# z1*i(HHQyTvO#@#)yFX+k_h6uIW>BMJda0OSSY8BjKB;~?9r9~SyMxHBD~F+iMH??P zZKU2wgba%N8B(Nj3EB@7u?b3M=+clDrpR5fwtA^B_4^^wMInYU_Zs;wQ@TD#! zNV2B9)fjmZ05_fDGHKpN=tI#XNJn1bR4_N~@j}vbYYh>szm+U}eUop~mtu9lq=V~=a z$}-aHobQi#os*~n-ncN+w62__R{|51$%LJdJSb0+vQ5hO){wMK!vDD4NsHictyv0x{Q79dU`!*(=BH%BM>FM{#4wA z<3cr}$j9R0ammSFDCjuA^X@$cZMcVRvbd)->!=A&`946JhZRO&IU^5-QIPF&HKLJ_ z*A;)0epi>>*EhpaXN>0e_Bnc%0dU8Y)?hMr{IX7$pG)GZB3kH_b%GHmd(*dT*UjUc zBBZw}qLWc*eD{9!Wwt7bK}Gc9<-BfQ62?-3qN7=$cFVWqRwUt8HgL0&QrHn7G2+#u z2J>w3alTqE&>M{N&XN1ot6G7B;1*57wT=unOo=u)1tkSBrbcj^s`tEs6p^;@u77P3ZK^yF3Z?Dh=+Dw7~xtCH>Njtshhv~b;eDi!S zotRYhP*(5aMb<(98b7vGo)l$6Dotrh^_uD(YQ%b8%`lA;^t^tW-f`3yt72VM40KJ^ zRd&S&R)l>VR0}6+v07`Opy){WjJ_*6A*PJovX+5`G26M5R%}wfpTC=L*iwy#mhuVt z<|L(e3~&rv0>A_$3T?DO@#P7UEzH2Tj}IpB0QPxNxCm4gXl7x97sU>s9yDG}N>pNk zC2;9fG*?_puGy7;@WQcd+0DszLeU1P0wO&Yr1|P_@-W$mx2g=qZMFcCV+Jc8y_1_H z!UaK5ao*BuP57+|h$BHpKwP^OXq9kKF{GG%eu7O4v6s0Zp^|+gymyM<%(kZ;3n{5mP~qPUqRCu*qA(Gat7u~>n~8^gD=7~ zF#+ZWMCys`6G{+8Hw69^=`bmn{^-L1#^q{5USN;&x2q}UIBK=~nXz>}&8TR*0)yOv z@SvhZ%V5I6!9h7VJWPqbyF-ZFMm0$D3JfWl>R&!KEqNcZ;~xk(Vib+rmXr~5|2qh4 zs&I7D7o)LgRzcxPEq@dQs{HtRAZmxrd0OG1dVo3;7e2od2enwc}kv}fe<`R@ICgO-!d>~S*{^TTH9?7uDy zFH~!W4L!Nx;8pill%Ec1FO{F}vj*<$gTl!r$aSXOS~aW&_DZ)NpWaWY+3{KAPGWS^ zrWd+4VEJKifH5UzOqdAVfK%`1@7^P+oPVHg3v$l?3)8|Z%bz!r&^e>R^gTrFSek&o zIyXJ9m!}kxrKG*x({tPhJU8xk>T$0%I_oAMkD{~lN%C`9At#%ZlM$)x@B0c~cQqSr8G^C*azj=WLtg6lx~18)u6m*Ar{{ zw2IKm9Al%Sq`SgoK=(_TX4}v!BJ;leg)FdDF@9G76?Q7%GCphKU6CovL^# zJ7X792M4>qUq`Q6J>0u6XtjWhcjmIKr&L%hF&bu;sufF&m6@gL#S$ZFW~m1BNH}Y| z7$kH#iqMJCxmx|`Ooh;Gos5U46MQuRy%`Gkuc998f$MQJIHS_dLm(wDn}>&ofq6Z2 z@8Hl{DbSSUH$c*t;?0X{l_LtiDA5o8ybv$#stR5u`At?mIPIR|hpL{+Ppql}Vo83J zRcr0m)?O84OY)npda`}M65J*EO;tVZ)av!1MpYZtqtk;UIpFWODERIM0|TD+hOG%c zxf%lL`tgg=`R6Rg)v(ta=74C>{9g*BCH}#m91w-l2NH@@Re>}IM4_|-X-2PJh*H&) ztpoN!6st;*QdI@gTo66E20``u?0k$4L{%|)gY5H2Rkv(ljaxrK|)oK?+ojMG}WE#tIS5ZY{Hv}rBm zwz-@290oz-AZXUAwfaFbXdcv4mlfM=HV+Q!@J}r~2OOoAt07 z*1~!a0Dyu7Ol;|@*2E(9FgU1(VWZw`)KBsuK^Js`X!2ULgRoisrIUR>HGu7LvY63` z%MS|yCCEINsSzuyfdliji7Uen1KIs}%hnWV+S}W$tFoQ#Wg7}^rv$g}1hV-L166ki zP_=dd)yWQ^>U>8~J?(~7F<8YuyI@)TlL^YxqpWVTL3?_%`pjqF>(6%tk3~q_7*T0Qj zX7I}z%`G>>WXOCK$E2ptx`Xbh)f3%zFS;6c#rP!%jI!!rIDw5Qq6swe8k2mruC7MI zt5JlWH#z0s{_2ZDZ6rDj${_0su1RVgu+YYS;76737J3@d$fqJzb)}R1EAO1Gr4|aS|2Xwv62UR>}>Rp|; z9FlhSZ!%M+lCT#pdIZ%Mx2YuSg-xB1dil%N673?7^p~xB%63x95(#>N1RjYG5+US~ zT=pxWgC|G-h9doJ2*uc8280sqFatsfc9;R71Ut-tP=X!ihY+4e=agXOI7+rSn@51v zkSW>HY##a5=~D}{dBoRP%@f~f{nD$3VaXO{^MdnL%at!W|5j%P@^PVido}8g$K4L* zA5sUPtwBeecW+zJL)UHwao+K%Q(twf5=hAsSk86Px(%IQuW%9Rd%?f9mcC8jVI4j;HSqsM*Zi z%ii4)pb!{@VZBxYfvOJjb)(*B?6Nz8pSU|v8u^Odfr817yF$*{-U9FR9W8)~MBIbPr! z&YRJv7yjDFk~v!65*VHhHFp$<&RZjphwy@J9)K!ycS(w~=>L@inl-6ZmgLt)+L4P3 z%6MMlVwKoh`l{4)l{%kP?Y8P$=c158RY}Yx47a1j)?O6W zs4AXb{Px4R_!vVMUzM7!!o2`-uQSA&wH*)(jpjKp1xhLE4SiT7D#fnsI+h(AD5egT z)z|bRR%czS2X$rp&g|K{Tu`~0YuLV3s2ZMwa0M}*V4N4YctN4otiHsnpv>b-n(TJ* zGQxvF>a`SMwJbpG*@7jD%aUD)}@gW{@l zRSv46aM{8OH|_3tJRIdw(f@_onHp9Jep;U#Bx>nIYcLt{z@YVHQ~Xjh;c*8e?#zMIzhub}#EK(BsJpi2P&{%HnVfldGq z^qq}>}+3c z24SrU-R^$+&TxXhYNTAyUm@k#!8(x3t&OJ4A?0|&I=IWNiKaoxe~i%#52=U4TD_S=3oX}z z`VmOq{joJ%aSQoQZ{%Prq9K@>e+Kip#&k? zfitVbR(=b_{3N4x&?IV6C9;uY^@n5%uOYcjtb!N9*C~&UKAPYvDupB2O+^2HwXYRFqqN;MQId(I{w0q>bPvwH>^&ooHYGXnheXr_t zVlHFnvZ_CmpBZ5#r z9O99KR|Ona9Dbd_FW5vBHjty;h{6kwj0fxef?If@%)l6m^+klaAI0!goD8oAo$(8b zE*P3{vog-yvD~6jEIeR45g;(K0|aXK9Tgfd$_@<}rH2Nb%Up@yJtm+UV}Uy_M}M0b zfYDz!2HXa5eFJDF>)*WxOuQpR%xHyS%!1>9@Vm#T>^=zLNF4Yp*U!75=dG#UrX0fMC!kN9WaAL9G5H|AfFyu~Vb0KvrbaDq@Wu`W=u97N?l6

bo> zpokq|DEt-d=#4@>U@Sxgp?)9azz0MEs5sUrABx3tBS4^X*3wE>{VNiss%A%`N);OI}@tD^#1Z7FsJ@NQ|e$Y#${{8lKQ6`;$jnGDV$j1Bu z8-HtW3E8NVge(450vdO9?PTPRv_fF6pa{H;ku2j}QxQ#XnOcrA^&Djyb{Vp;C(AUQ zcIw_T2TmD(JBLnRfw#<&dl2j^gQD2Bz5)l%p?A!I1?O@Qdf^k;a1KKMcpNx4YThyi z&gB4zn751tXFSCaP8`n2GO0MxE+Z*zNSyo1SeJeaUMkWi%OsIDS*Dhwog~sG%OsID zStg0J$udc#O_oU_ZL&-fX%l5UNSiE^MA~GTB+@3!B#|~*CW*AkGD)OOmPsP**F}>2 zp{V9B^9$8fkvyp8U5gm19epQM^UghnYK>f|mLtTb7xTQ3jbWaD6>B-l)N_<^G0%^k zKL+!>E5w-hCh$96|3J(O8{3Io*zjYg1LtOS3+AQw)lBxa1Lma$5&fYw&yT@7)4cj& z4$SknvpeQ_=?7!pmN=(g1oRHwMZmyMj%;w38-B!bz(!&J;vkgqBas8}lroJReKnJPFz}bz83R)YFJWLcP7IUxDSsFait`J(U`A-# zKV1vl^WsOd&^ z4w|*YZDdlH`FgzE7GwVxV*axb^QZG~3KdU<3|iKk!n%dKGlB;3D-<3C4dUVZJO~Pt z*ovTO?fhwWp7_mH8$p9VNy9E528UZU?8D&bduZ6@!|Ksi4O{i~b?6Dp`3pUN0R4;` zfPUdl?kX?3rR9tHq3Gtfne2>i{$+`wo8L6IGrIYAxVEcs zNZ0R$Zd<)wzaMq0`Q^YL#b9$L*ZGmySNE^v?!+#SRquPbTxVGIhUxK|zZwCzdl!B; z1WYmh{V)XdBpLd}TL0pb+}~55b#nsMc25ZOL-Ep&D=uEeCSK;B;Gnfzn#;d8YW~-n zum3wyb9KSoRbUO4y{^d$UVTJp94*5y=m{+i>DH-}ZxkJ_W5 zHqhk2yc{>vQ_Adq>h@3elKC5}8C!DPy2)eh6t|q?RwcQ`#?OXgG6am)IcOu5s+I@f zO;sCI5!penzV6Dmm`bcG3P5)!P?dwQmc(fvf1$??w1R(dXY^YWQFsw_Mf8(ly>WWNU6Wteb-pV=zvXd>`Y(5iPAXkkgv-J3W{{Te z7C!Ji*5Iq|h*G!#;1N)J^f92X^eVmSr}c6{qaIZ*D(BM${49x!*#@(^Jv~2C3b)?$ z?Q%8UEHMjSaCA@;7tae3gt8p~!Sv~AHpOhE;>CFRNO=N#v*~&x#{c(ux|*%AvA2)2 z59=2t_=>5b?q+4q{0r?FFT*zG_gX!3Izt%LOU!8a^z=Bto6@7@gP4jnWtNmR&X>>Y z+56?=J!V71Cl+@HEk4a3A2Ac%oq_}<(^E^#pa0BOOVz=eJIC~in4%9_-@IQfpWnR~{fh1o z$wJ?4gJpZOk%k~lwP43~fYx9PUbM80d0zttscBpniY44t*H`#!xDYS`-UI+6c!|Tt z49jZ^5+4DY%axn+jhCJPO@uiCbB$QV$L;4 z8rZ_3@^uoZ)pvRx$Y%iy*?lcz!;o}C?H*%MnDp<^G=Pe-?}ZR@m&;)r8cMP z#FVyN$d&)iu%R~1yNZxh0}rbPqWp2;${z<#VP;Q+N~mcJx-Z*3=he6m&uzHwQQ_j= zUKoc$EdvVF4E(b%Bn;eUYFmZ}mD|0&@$aKaVcah!pkxit0T)#)$7TeK{#e*G$|7FE zdU@=;WSBMxr1h#ZV2w%=k6Kq(z1JQbf)VckW94e4B(>g3e3~b$ zP&>11?lQ}!J4fJ4Lz;Rv8;?CF)R$|TTR`C4{PO95YtN!-P!v|fpwqG;=YXe$;YLjcJZ zhytZ{0fq(2hWvU(UyJdre!yEju=$k!&|XLWBVk$6VH>h_zNB+N<*qm zV0F2hQPYPh$d3aH38Bg) zD&yR{dp2shWkGg9m7U699ktEvLdfgFthJ{e;U5iX=VeX5gw7Ig>-e_j#ff$y3X6L& zeCF{SRYjD>b%f1$pp9CQ2w0TB5IwjWg9+asRn1E;bOoiHeKdtP&fcI&gA{oiM_y-gp* z^zQEY!}FuIs;!ov*2;iIso+`7kC|M$pQm@5$1jvgel>shep7yrCX4m_UK>d;dHihk zVZH(Ns*-L3ZNs-SQW-l(TWq2L3pR@47ikr}?7qg!%VSv5>k+W{Q&tv0kLk8R02u#% z-5PbrjscY|oh1}oim2Pb{%1o<(2rwv?3MU0z{J}{P zEhq2;1Z-OP0z4|67of-){u2RlH3sm>djQ$``R!`?yqN=B*SOMXIC+F$(^blfqg_;5 zH)K0m#n7Ypv;;4N1Ch!Vk1h&ev=fnJz$z zdHY2SWV5m%*cJNCiR$sBL{=_%F?|bDecsGKQGT4Qri(l10rd9|v(0RUn@6_t>HTs& z18gSK3L56tcdPkZG+@mhm!IU&p#3{&?1Qnjz_3o#gl10w3pB_ir$$=`YTv_L=8LD?^g8tUaw~ z&-csn98D;&Ffj9093TdnALc6nqqbpjm(%BWXa!Nk>N5~gaYFX4scc3)ABlF62^m^G zfnIIqPmf>lXS%r+jbEGhvLT5SbLee#N7g1p<`&wUp5NZjr|*^vAcmGH-Cm}VfR&LA zk;xqZZ9tO05qA#7k`>p`_4?sU*6M-QJt{=N`HE;zkU#f<748Q>Co*bAB;GY*`?O8*6HfjeEdGWEifsY@teA=+4nfbbDd&%0 zG~!_AQ`nLU8y0|IC1~dEJ?!R^#FNi7dL)4aPeQi!GXX`TvV_9g-ie=Z4`LIm8S-FY z?ax5}R%peBJ-C$nvwH=6uYeunBddfuQdX~ky#Qhg+IuujG;QKUaVZcGK%%BkKw@CL z)6EPxxLRP@5cIUCJ8H%7h9LFfd5x?B(4DNMIA1cmuI1SuE|J_mclh!V2x>)%4`0V3 zD@;!m-65$$o)uXrG!-k{*A5Am10haFqg1H(G`*X-lS8t%nrR}g7!WfCmhq<6ev1ZI z*ON+xNC=56D6NQ(Fn`3AHI{V+7+tef*h7ma0s^+C>Yh#4{0@daN8yYPcdTPH=Afw? zUgBpLgi zu8*Y#h$VeA$_!k=lE%C8pTyw@3NMzhxz;EQGo~;~0IvMOJd2u0Z2%VFeohr}z%YP5 zlO!e=GZJ8Cs}-GVD*JVTmKU*GHiE}BWO8C`jFDfM4Kl6N6Gi+iSDW`sCbsu8q)E#) zj|v4hYURW951`P?)D~7V67EnVkmQ_E4o6#&LqywNHMIq|4zFecQ#GQdHe-o^+c7n@ zl@l}OZYA`NjgGyZ-#(@f1y%xu$R{L|C@f?merhYQ)P%{cTjsT9y@SNKGPVp1cg85s zqehe`4~H-III;Cb<`MxP!EJgsUC;Q?diwZGR1wCBxI10For9#b$`}dY6mSuF`YhQ7 zIz%i#P;>KpB`2gd!JSGbNj-xwQpu23knEVfwp7>{R9b^h1tE+ESq0*(?VhMZ3(Up6w4I&L6`|IA%kuaR$Kfu=Z@SwfLoD-(|X}S6X z(TzA0c1E2N-!ToaP&kR=R)2yed}X;5V&-$BK-|i^QleXc+nq$PIrln ztUw@{uS}x|c9*oeEesb>W%ImR#J8H1YzLs?DaxxG=me*Hc0{jn_thAzzGw1!Xx;PGsAyUyS3dnc($`LDRRI{ zH)TtuOl=`c)uasz%P)16Oah&%>nIE~pip$ee28M8Tx*2)nA*`lINLFBTS^+WK|6ut)mAU~7S?x;IxchTO5<~!lIEsBeZHr{!? z4?V+B{)h>8#AtC>VW-3r`lmc0KM3lT6u%hqZ)Jzg5(W?JkI(*G&zPWEZK50H8aNqL zkv0!3|0KO%ycP6#X+-2Ur~G1SmGJv`(F6@XU!u|6vZL^woF_c7UjZ1g`sDmVRfl0h z_0jC&OD<dk86%O2gv7} zgZ~e&CMDhs_$MHToQo6qA02bxKYS#OEdJmpGw2b|PsGb=rBhXQjU28(wPqeyAhTkE56QSUJSW5cimLZx z39drjI+&ullg9vh59!Ap|6>L)Kd%Ozs_k5GiI2@sT3X9Y=MItIx-Jm4hO3|D@s+A2 zRJuI1Lf?5I`6F~%>a9EI)P>qAPO(|#OOsyyr8vw zp<*@eCo8^Cih2q6>EgUQFQpKz)?#JiR#2>jb&8p);C1;@>T~eSqIN=qR zZe>ctk*?vL6U)WQ+qr~s_|sub8kyF4QA<-A+n)jUa0jr<18eCsK)cKjpB&rdAZ1wu zukHn(#0R#AU#cvGpX)1PynJrifqC?<`vcMI4$da$=$GFSr$F6_8DzCnsiY1IK3E$j zf00#&-RJNO0r=A(tE51Qy@zM}^rsB0;G!IqdI^ubdNj5za7ME^@TZx%WU1rj7G#T#e^#=Q6bwvRM;hFD zYYfz-3u1P6f`nzz?WCd)09v98g%fU{w+3e*r^4I^-EODbN$DsJTR;T8z_lP$^OwLY zg;a`&*M-^xN9p*`L5D~s4teBDDMLCiYj8%sot zlyM&!<9_hpeQ|;m>O``!pq}D{*vPR0(y)7iWQVR4KnJv8nm!N4q^GdG5aX+EI|6W1 zxHP?KT(wg|bqISulEA)9Ay?2HT*LfMIc07 z_gW*F&0!ZN5lTTi9j<)ez(TDjE%_G&5mf z;lzfO+}awATCV{DrJ^ITUP@^Sw^gl~`{qdRs-uof?3*L_*u6P|#34k(^%mk zgJQ81jo~L1bR6pk$Ae&h5K1Rh@}LsyN4!8FmN0_ZdPBanQ+E4QW>lSy=nft)<&) zKo$7Al?kgoeSGA@ei%7)`))P;fEXDSM9llxxl&?%3TH5k*T&Ond3X2xgfUXcC7j($ z`qcT|@=-mYCEX9m{f7KeVjl9!7pQPUPOR*GGDE*Namz~_9|jEMP0?w@INsq^f8`jY zg4|3u&z5&Mxl6OFIfp!YKz{@7mb^5U9&af6VB^O@Y}lWs=mCBQ3$=cDMz4zHTXc@0 zn^=j;AyF0$1%;@}6l zM*R37AVIZWg<{uF_fzF!APHj*_X3Mq_}mM0Bsa^!V9ag>Kv<$%@+|0Ct^&k4@ZTGD z8DJh`3v`34Kr=AMfj}MVyK8ycYIB$myA4BJweLV%bFUj7;4S_8nx9$v5qSi#g8@Yk zfez#w@(iFi7{KEtol2A_ipNVThK~aB7ue0nzNP+wvl#m2F{`c!v4?~3YTcA+iVx#A{kbJ6zE9nZ;9X$U`JtP>nQE5g5 zE7*ESLOP`z&TW>PaX?0N_QhXs-zX!y`Lldv3vIE%{HwIX>WnpCCv*k(CB7AiPF}9;U6N=I}Pk? z*MSAL(IfY$;xy73RsRYQZa`s9<<@_lXH=?ldFY9|FLMxtb%#057p#VTMoEVyX$Vxa zfMG!*qcea)dPNTe*-qQNK0ZY)`J&sV)6s&9c*X1EYDrw9Qd6x6pS?#?A7tq6j=}vx z342MyFQBSd<^_s3ahj-GCA9%$56|wpbymbbUC;i4{Wlm+MEe{~1j-cz`Z8EDW*bE` z20^fOh672oLGm=|O7X78EP*7?bjF3y`-1U+8@w4K{*_?c!k;qy>BHQmRRUM|R(f@2 z+67tWjK&(1iax?-4i5Fs(N-A12=tKvFo9mtI>GIA0z@t`Sw-bVS;qOX_?H^5pIcz1 zeUv2k@ZfgbmKHgDOb&S?X0JWPP(1U^46u?ZfN-=J6}%?J)~~tGo;9_L#Kd;7s@g!8 z6zccm*X6StjHmgkJK}K90O$yv7Xbe}Z76%WcUCGOOu9FSqHq?mQ;X-4WGNqK1b}fq zsR!*DMsq3sTV9ge+z(|hM_GsLTh7vn_lI%bf0&o||Nf1fKgbZp#dl-f$=6@Q{2E=Nx;DtYa_h$O~yli6}_Q*_W{|Cqt%DL?^x~y56kF9-b0vAkLIyY<4caE8+LY66RiO){lQ#g4tNR4p)N+KwiIx*y_Iyb-*@_rYkmQ#Q$ z?gPH^%wg$gG7=z%b(zoZJzP*lEKAmQV-e{#yuQ5rkvHDmZMz1L&3qkOr=b)yWkFY! zd;9Vb(AvBvvQKOAg^%tKcqCpSiJ~tA$||wT9&yb9Ew3Ht&^rH9#DvZd5hExOf_kbb zRbtGAo5^0ch!DeXr^&n11sr5ieZ!DX1qU3-8asd?5h+aVh`aYom;&R;``Ps47x8IE zhu{T_eKA{1AA$Vo&>2N>Gl@YX7Ey^A!S@NNbfZEl0Y|Z-Dc$HGMEC4E;E(qr8v#}X zoM=$$;g6KqM>-rDbOjsglp-h0z4z?z=j*%YH612C&NkwC&Ec?+(e_a&lRI*TfrV~- z4aA})-B65~N<2~uzQBukz826`ArS(_`6OWF#GBFt%OW}%x10*VoIL2NU$+oh{q-V6&6_x;qCGzL+=Xqh%c7tztghy?lc$pq1 zYBl>XMcWXL!w} z7s&Ey!`?Kh>3O0D6De=LHguXd5rqa^Vz`?}UuBDiJj|w>XC~MiKO)Gn2gT!n2#fW* zQcXdgAu`%ebKtmU=5xur|3Gd%hm9m%8E~02+jTzgfGa*x7z+w(Dx-uvEFT}2pRg8s z1Ni#~q5RVK9K=Db)HyBFqeg;JTey!rCY3CLgSZW)(5KZH0Nn){d zWwA-G^Wnrp68?+X=M687UKzwWf1DS+{E|vy7|JJ=H|P_RS}l_K_oDc)T&ev)1Ld$3 z6myH>DEg{Vpe>x>F}pZv=&X6sFb|ww@?>=t0Y%4WyJtcmBch1M=@$^!Qjpd~__ajW zwU62ZAv2o^hYK4FHwaFX!=7ot8=xntc|~^`7LQ?m(8?dPFKSUGDPgc>Rjw6}2`H~x zJy6>Uw6KgV50a;5HNtI$OjMVLZK)?*Y4w&3TXoJ)@ z&mRUgBG#$9CxvRi;w_?x14Sw2y|Ccmh96mXBIf2NQ!SUk5SQeQSj7+R35>sNvB+d2 z#30|#9-la=8b*iaIJ5Hwhq}XPcxptx20nTw!f_oz(w|}=Kfr^T$KO+6%)c*7Nir0V ze4JBsQ)teRGhfx~1qOS1x0wHjgcdah#V6+P7O)!k>0%2Ie-q48Et(x3P=@FJ;)eZo z+j!756{C?(d0H^g3^YY@Q*k*f6suRQz}=U-M-xcaR~5j8-i^%9?d`&%4aOyZUTiWF z^%?%Ary$1;KtPF3J4`0)-T*H_CMpRP^~5oc*J1!`MhK|U&MVx**kvGdV9XQ)Tk#G{ zUSj`GFFA(~CtM#_QeFcl95>SyX)y+UWG02T1%<$L#jzb>L4N`VOd7y#Ew>z>yYpFA9(kQ_>zw zB)X<7D2cW*_#%TR1Hy+H5N6L{6Xw?m$7u!n#PDW*%+d;t;V_)*Yt-#sjZ{Etm5|dL z>rfIzV2kSy=;Mx1gh$*$NowAhRu<#4mA#6S%pm?iVtu z9#dMSiweIi%XTClV$jUH7_ z(yakWo(M<0RveQ7hK-&WhE%8hwC9HGO3pBl=fscueY zYZ#v}Ty+Y&&(@8FZFm~&*NpndN*_Lgy|1U>Ww%BxJ`e?$=_)P=%3X>!@fa1{0&*Tr_?^wMZ6eJaN~}7kz~g7M4dV~u;~!81 zaKm^@Isz;5Obi(QS>pAtd#90*gZruo%&N8wq)SCq7+v|pOT=Opa1Oq0WeaC>^ar4m zQZ-AZgfv`xLTVxlP;QvI*giQvTk&H3{O~Zpnb|^LmVu~w$=B@j?2fPXXV z11B7<-4y)M;@m0#}opgK%fmS zDVQsLzp8X`UZ00AQTRiWW?!_;N^ybtKtzA~x#FI!$V~O@9PyZPMrl5^y~3c}D;A}} z2~B(h_E4Ehn!1!})8G%A+l}gQ=(jo&? zc$M9Vi*$TtnKvfIgGY4DUXM_SYcj(TVWpenD{VA|={?M7IN75xC$_8`+1Afg`=9w( zhD?KqDu%ps3H};oO0+$_TUdg`jUzKy#y~}2>C;M{0XxD5uBC$G#>q?Qd@wK&Fo;S_ z7LvWRbpE(9ZO;3z>tlc5i}z2CUCPhP6Yw9g@A2J|RJjx-C_6JIEt;lJz5op(-Px~% zA?cT^jTpBEor8mNwb2MmVhpX!r=E6t)3+c~0P=!#RuUJ_iy3AbI7|vu+h#phK81Sj z>y*ip*HnHF$g=Q_8&!(6c=rs#m^)r{TwdD>|`zeBbUb3WRA&VTkw_oo0$ zO#Fcck}KY@AN*t@1f3!{Iz(OJ>8T=)08D{rmF@ZQX}=AEl9+s2#uhk*zvf?H0At(d zG&I4)Ceu4+N$6i>PjYSbl^mbo{oKt3X*r?nUQHl*|9e zmHaC>+qO4ghwba0BO!>=7GxLFZyk1zz2GU^ z2l}U?13Zj*)cyTB8g)A_5|Gb1X6}Uo?8-|!bVDv0+gFDo3R`mmTaFdCe}_z$bNjqB>Cb6tUx-?n%k(QJzbD43A!*c!2(59`!=~tyc84 z!SCw2RHLXCI{gkD=0ZnA8u&0JRYLhid1bG$|yf=)5M znyHg`Z*{~gQGohi_+rkK`rf>!qja5<+~{g+&;n=56-3RQlDR&wp6I&E^1+TP!w0DoNlBjR#9F=5U(^g{Db5uOGlbzkq&>m;Z$s)poU_3%fnxQL+ zX+(G=n9_vz3Lt(|ITtQB$&=S_UL>-+$BqWvUeA9JX3&B2bfwQHvJ#`p%N`4^7Y3f*(v3F9*?1xo&dxNRPM@A0xeuKH z`3&!O+E@^Sf;+W0D7qq(N=(nSV6>puRurD<Xeeb+e5u|rs!R!4 zuq77|Y6FFH%e2$6BCNh4`k(~z+X-mJAWY=mckT`|y=85+v`yumZ)_mgX&k83ik?F( zEG;c%3I1N4)1UG0@Gtdx(i`4f!)Q)o!O1#9SeP0HvX%a~-4;WaV%bubThtNzg$BY| z=DEG0Cg0exa^Jj(4-{vt8jq+#G#>U47f20(KbYWh!f&|63#-A4_7K#b3n+QneQh!T zqgk*uo|NcL3CHq9^nta6f1_9M54|w$3`l1hU`QGGGl}|LWuODBj@r2V99p;A8lS-M z$i4?i7fomYp!sNEQ#4)$Cn_gj$k-5Q7<^fojIO(t9C3H0zNOU#P!)jX{AcDw!Qkep zOXWmt4k~qi`sr#jM`sCA&9aG6V%lnz>53oz6dgA`fZl(L- zXqW@4p&p?L#rmlu(I^dMsSc6dtGv2RjFWsUf=Z`cPaQToS&Qc<=|h+?cHUtaAF*}q zT<}*d#UzV(OUCCJpUm%P?8`2TS7KHWihWi91clL8O9KAukcG)a*ndFP@9pw=!M

swEPI^oF7Mgp>%rrvRy|@*fwu5(`We>+)Y( z(YA}>4z^o7KeHKpCuE*cgwR552DcfluO2?-N%Rwq_GVS z2?gxqEBu+d6UDBmD!y$$iX1p8i4FxOFb|pZ;B3r86}!Hg*x-Z}6iG9QfhMY$D4+m` zxjuzNLLO}3gr%1NxXR>GD4$sTRW1jJPxk5JgcI{hCpiBRBnd&{SSME_gMB|5z)*XJ zbF?Yj#!TM4kZjMW_e-CR$n{G!FsgZAbR)ME3AwR7iWL$m$|If{OTHM1xnnjoORMk} zT8*q^xF;%fo7Ks{31%tPo@3d>OSwPxKqfG-7%r4VwZ_{lckk)e60ql2t=rjJ-iPjp zhsPy3N|)5tLX@Rs6Lf7EIQ{IiykWGWBYtG03C}aWtz1%K-pBd!dHtvw;w&iYPP3)C zeV}^`=(Y{&BWB)tK#@gz-&yw96?z2BO6qnl$Q%#PD{?uPm#dus7Tmm9Pz^Ce8L4Wp zsKyc@P?LoGp@f~dO$nzTvl2;by74-aw#_fb#EACawLPHm?-(wXhGLScJ3(BXfT4Ij z*)~|x1^4O4`J;;21cNd5Qp-v*dj#kj<7XvK=_90y{jP^sO=y7Q-<^k~0=bbmyRf$t z6_F)*D+X~Ir+>0i94Vfq>+#TW8(|Z_aqQRxAyUF`%zDbcqp%lLZ8XyW(|7wZHGo>04NID% zb@r-GU1Nu;=0MdB^KK*sE9n*Q}v7WJftWxKxNh@w0y|PNziV5tNf#S5s zCvzkBjBve~Jy}-vYuJg81s;i&}W%aBq^Vw9$g;m`^84j z-(e1ltW$VLz6+ ziF3*H?H8O&L1$jnA|zOoy|o08d}vOw7G zVU&W?|033xrKB1UeVpKtvQDg2TM|o1u%FKExqbliJXEK6-bN6b6 zx4769R)tj%Z-J0F0_fE_3dEs76Q+m>bxr1Yr!=_xu$wHVh8Xk)gY!EXY!S9^-te_N zuMq_0L(G8jvVi}V-@Hj?z?$IkF^$oW#&u z^M{QNyMvGS1ML|!kP@i{r`ZFZla4=4pPZ(2G!8somo{Q~dlG%GK#87xv>ig8pFk`S z=d<;CwgCFWaU}JT2Jl?pp0t7e2$~zQ;AB%q0a?v#*PP$_7FQngdngSpjO9197L2oGQWRxE*5DX!Mfu=J6{u|@nw$3HLvoSXeQ}9q08yJn#n%8*# zVg5+Bapcr^ml;o;OlaR0G^hjhtLXC0TkhE9-pcyLf1Np^(4j<+z}+$q`lMnSXQf4d zKl`?mg}Ux~KxZt7?DO6!Ym=N@4{0~!^+?bM=DV!Xqor3l9?NF{8hV-}mHc^wdT4YN zAPPk&tEz1r6PjdCH`pS`C>aKMYq6Z8aLhT#<_L9KAJMw8h~(3qoR8{Rok9B&;;1q{ zVJ&4?l;EsYz$tF=|j4xT>U9#ZUlKF@A*Ilv{*vf-|o7NQ# zod+HpcHrX;vATg?1txd)l6X$F6rtBcOqNh@OtG{=UfRtc;54FxkaM=z$f^;&;Yw?gIDUifKy!Ow9LN8SA4 z+_MbGJ%-)hUicD?b*MQOCavo|HqznqG!iIwqJm<_#rFaFTi0LYLjjQo3w+~CL4@tY zvM?nR7laQTgx?4vzK!OIZy|dk59Jd%iJ$P$zf=&Wt(a#QC7z%Z7)fhNSW8s`#%u=R zpfW09KPd=igNOHrsF+HfAvq(FH&0uqHgM|5P9TA z7O_c&gNmq@OGxA~p8{QA0k-hGxL-b4!E#h+D$F5cN3iG(r6 zo^V{j4(nBA#qjIcNFAi^V2ms>e>|lK59?c1Y-RNbIlUS-Ss4r`6)sV9)6omLZ(Pg8 zPNwm6)rh?t->^oM^dw<(Z;viIx+;~dX^!BytlDUfDx}Y2Q$iBq*|_u#pxA0_v6!J- z!_@XD6voUeQNO8ymwt+x;6LdG6!K~h4^xTo=^Xas1$%%H`J#%) z=(WsI(aDsqj9r>uS~OJ0oSiT3&>!@j7G9Y0t!4n-nJ;#jX#Ufe zj0?#~K2^sljv-#us#yy|;uFpiWwaZQabH4^d!UjDWR)-dcH~+$&31%6L(Mo{##1ea zF>aE`r&$LY5@Vot5EK1{cvcccPlBIq#7Kc?jSWLr>qdYfgO5vgX>Ijwu= z$zzq|%$y0YWwH7@Q{?oDP+GbcD57}X9Nz0ZUmc}k)_p=qtv=O(#!ls_y|IhS} z@(r+Am`8|ab_^sc`?CYGSx2b%GxCC1E9av$3*5fn0+)1$CFTVJe3XKPHbL&o(@Lzv zBpH8l%>+%haR9z^rFaQ`>LXGyv#O`M^Tsls-dLV$PDwqS7;R4w<`I(%xe^Reb*yDw zSEC!Y9!t7u$ed;4^#Z+$aUx!m-j4ketP#+P*y-*C!r>xrJr&a9YWYMbim(w0m2rH) zp%Af4jP>TUk38Sdg5b0wtqBxI4qLz-UeO1B&zw?{tqE&wdl1vN%UEI(5K^W89`#W% zcf;-NL9*rh>FS9Oj2>VoIIYN|BjYkAvz?ap14`L8U(jVYyv(_d+a~xt8U&escRx*Q zX4=_Lh%PODp+${7l2#bUj1!!*c<3yxR|r=yzJC0f=w>gju-S{N^k#)RVgxeTO63mD zR4#mql$nq(Rj}q2c@oys6tOQ4yGeo{rYC2YZ5&893jmOm#K$N38eZ8txam1n^EO3N z6wDN3fE4G=P;yxXbZ^-f0lgSuy0S`6F37~*NUC?NW9*v{)DPrQD1i@Xhnsf(V9QFp zDea6$bmAo=`&VS*J?V?Y}r(Yv$@|Sd1mOTejkf zbhCl7&f_;BpCh6_3%~AfRmtDxiEm)_B4O9LvENEn8{V zO1J8W*AvYT57G!>@WftCWyXXxVl`8O2&t#C5ad{5id&O(Z8CuN+RB+DFm!-fkXIEQ z)mlFGI(#9pvz3g;A6qq#)=Go76jy9|C(V^Okfppr139!;s+Fdk+6Fdk&R-7SY|~;B zs=TYkCNz7A){g6q@bCa_s_}1-jH6-^KP^rho9+T}1Fy@FgPt}D9k~}v_`AGx(lpvg zcW3{}itP_6TX~@ShgL-EvE__dk{*npc0&7W6)M=M8Q;ZC5tKKzg?^+XVy*tm5%I@5 zBG$ZiQI|K^=#}F3pR`!&G~;y7C@XXd23(*72oF}26vtQ0JdQ&ZaYWxMpkf|f@;nGd zAuQn?b}E9TwimMzo|Db*mZQ;0Xw@3qVRI_uAmMH$H+hsxW=#D3>6S5MKUC1$*O}=z zn|80H3r_sX2LO4286+^*5oSbmE_T%pJy$a>ejk&3B4>u zWKdvfYECs}>Cv{C+wxJmh?5Y_@@@+k%55l8T(0JGQXI`p;vo$g<6!Sz<#s`H4wF-_bo za|uYr8?z3@;MSOX#E6<_6y&B8v<|bQ*^O}+6wQvl$Y6Gt-Pbq6QD=-{0a{~EV8Npu=@JK`*Q)g6ol)NSEa*OI*J>O{ojXwfB(9bEzja@C6m#M>4!?{dDl zo6hfHlocoiMXoC-YENdLr|VeB)$-l@k~po1iRmjPvYz!h5k1ioV>=TB7wW)HTFswS zc(N-U15dY7E=LOxR?1eczk!`fLE3XjGMQsZNumnY$UC>fbDfeY8QsYo=w_6+IAEMf zCAfZ?-r?p}wjJFk^xwHP-Ms#aZeHi?hLfT*<_pm%D?3)Fa#c~zk?K9(cLG(XbJ}a2 zVcJaq@mq}XHG5osauuZB@=mhNu-u@uf82q}tzr)$9y>i|xt2!7b5DnQDTkD7#ac^T znbmSbVTvTA3eO9jQuYBrhQv!$iw>0YR&j&|PwcVS9OwdZ|0i{@u03zXvqSG1^vGzDjNm_m~UC-~-LDKZ`-R$jZYDGY0 z+4FR{LWK6TLie&uqNOhy4weFh=sk$&5%?-+~o8; zkml(ifik>9STY2q>rHnwRHAa!2f>LJkYl@bUh^Lnu1rau7_ioF=Tcf@TFwDNwO}=o0lI>|Yy%g1W8W8{-j@c~YK`jI+-ra|aAz zuPPr@leWUac+$NZ9}kF8#5W^d7{##^MFZv?!2h*sywFHxeOSH)6$s-UQ^*K9R+E7) z7SK}p?c?(94@RF#d=$DP@&Ab|?@OLXBk4%j15`7O93SUsCD_)=|H;uv&F9l6*ix70 zFbZ*A;X^%Pgh8BFZ)<+1P;`OON;a)!iB{5A_U5>A>vv@o;>|H^jFfj&>-c8>%^nWd zU*t6v*~1aSo*EvYF1W{r9M;`koe+Z2)ZxfXWg)d(x8>7;xM3yT#1lIllwq1hW=-E?%c$csD z2}uM7`897mfUt2psAj>-PfM~%fsDuZodK3YVI{yE>iQKB3$`$E2V&vZKx|jk+YaN} zkAiU?%+v(c{^SLA3il7{senzfDLYDbwr%+g$VvzGiw>zB`0aI&-?Dt>nwHy3ndRd< zo0m^OTHS76KGO!~vtJhG?_gmD#PAq$IeUXC6K*eao1>lEE$t|aFWGq;Wo7A&S?Sn( zkjKVrXU!%vsS!xL;R&e{(>=(r~zmibAVs3=O=ci%SbcXMwUf{VW_!9Tzfd|0jhpwuK({ihg`n@(kEQU1{u zl>no)iz$zXCD(u11B?omC3N)2FgK}&Y zlJA+dGh@Mfkka+1dv@JxjmkI*9<&{@TMYwrxK4oFT|N07l{b4}fNSuC%d``NZJmq@ zP@>3Q-TW)m27Tu+fHcN3H2l(Z$InT{3|~Soj{U!LeGC{>#`mPWIWH}EUGp)z4KC*t zVB0Dtma>+r&RO8M&T!0|4#D$f=Q{a@7Tovd7V6vre6QUhlb=($eGckk+GwREsh(KZ z7=V5clUUyPCI~h1KnNBu#mWm1x=JeQWH`8mcdrw-dKeY!Uu`zS_n#tA$f|}D0);)+wojJP9qPiahS!y2%v~P z@_}3TF0zfXNX`-qmEFTpf=O^^(b=$6Kx=r=fd3Dxr7+OSh_;8L7{pd^*D_8vanJ>4 zE4-?=fj?8aYvh>5$K77HJt3Y{fZh~ur{B&?!R`il%R^Y7(2=-4|3Hj8cZsY)VM{9?**ohhUw=%K4>N|F%>{z@D%_Gb2(8+;cp9o{OBeD z`g*BjEn1e8 zxAo$&@3_ehM-!&gOS`3zT1xAuL8Hj-XPY>lr=PEyZDNdJidgGfg{?Pfmo6xeg_2#& z$=J^MEw~B1FfP-rdeU0>&d}rlDC_a{$vEmntE8^TLl5!TMVns~J^gmtDF^;yKnyD0o&Jm4n z;rGkCXY>m<$>Mb}vhd6F;xn25Xf6*b-1OLkB^03M`e?giKx{0q}mmqn$sdT^`~hjG#?Ssxm+69TQ3Z*$HB z*mla@9NDZrmSx;CChzVfkbgt@w^q^_bpO6dt*cFxen(t_Lznz96LPw8w%7(u*h=`m zcJe}hb8_r_*{yS@tTu!5CZ5(rEl1*Mnck?Bo`PCZ!IZSqs`|M<-Ly(BEi2o3gtg*r zl1uN1(<(zdwX!F~Haw0`-Fm18Mm5bvzF5v^lO)>8{S4ay=6})};r#6+&}Lwq4LUvm z7+9baK94Y`v$%i<7Z);_vz5pB1pbGGrWDSm**-nuT+UY5Ml~52cNf}$wQu#>lDcfm zv#fC^B?FVX?;p#+)C=s=HIplo63^iqw;7#`&}{~@cbd{xGrbeRFNlLt(-@mF`ZZ^pmkS^>roA1g`>%>cC_=;hP(b zj0eKq2`6bCuC6foCS?+o=on^t5)b7TjVJ;%ru|SCv?7dPw&MF`swkG@YsNw?DfMB= z_&T50BoLT}LE;#rBW-&IufkHsa*yESd~Td*m@+kkgvfZz$xARwAV;0?M4U6js?o5x zb47`i7zV>|ds0#4lG*mGb6yUiW33A%^6`bgldf2#3J_Vq;8AkVA$-)=5M3%q1<(m&gqDC9JeT4cBKoO+6E7F~5XA_=Yf%zoKu62k#5~73GNskNsvx zgU1p($AXX480=v17yNU}ppBhpSQF_M#|J`@UILL`7Xks1wp3RLAqt@^gtl}@5rXt8 zB0`X2L`vu=MVcrC6hXWwD56x6CT%f*0#XH}$OT2X!QJcC-MzccJnuX2hne3wbI$+& zX`Y!`kB#A~V{3x0-o2wBK`uMy<^t=_;(^JZsN<}c!Ag@`4S6}e+HPJk-*;Mb1-m)- zUCK_{O}%e9<8~~0bwewB*y#zPVEOE&_Sc1mQzFnH6^Ohv2e}48-@U>o1C!K^LCu*T z$L^h>tdO*nb*|!y-BZj4uikj(b5eH95L*nkmk}(tHvxPfI^OSyb#jeEllt!uT3?qP zL-pqzjkKK8flVk?K77$C-i7aRi-t1g5}IRgGlkee3!@z_s-amiSTWgnb-05mn=G=j zr#8-VK&4`J>O6{Q{iz{(H?2V8bt>bNiSv&fvoJx&{J?ES$J>B8iJyN}mXS0r6Szd( zH87Z_n7q%Bc;lEKt2{IgGb;m&$=L8=4O=>_F-=>CtQ|GH&BIYRat2?2Te5x;qZL83 zhW0?MS6uq4Sa@07F1y@?{frA*AcN#bnWOt|OtIKLk@*PKYqtyB^jBg|v^%VnHdRAb zCh#)aWw^@tFomOL>a$5H)n`hY2G&qnPm}01SJ~~T$&Y7ZiWQT1w{WV2Cy7{#x~3MK z!+?)OZ3(4LWNlj?mfUx7ijtyLErUL{bnkHO%!A;W0S*P3foxD43K6YKj`0Y1Ys{{j zn|7rcjIx|R^N~8~rvoN3WQ)Iu4{jz#|ycOJKdsECKE-6f*d9m zS}$PAb9A{G@bkL9Yusst(-F7k7x2@xH$q-6OG^3j^0?ypdGzARc7ek37YkF~)fk@O zvMQgS^8~i%);Cvg*$%fHadK{pyRO`<)ZjnW{2&cTh`oo|d_MlJC-kEyVk&R6Ll2Ts z36C#{Vtb$4dyU`ge*F!7diZ5HQmwTV9@jnW`N1t=@|S_y*njD_e)>gSsFYI19wo%s zt{fAKh*gZvMHcBxjVHW3R#A!Dnj*jXShToeieH6N1-Sl*t>O^*a0#a@{XCU-d zYh5XKM`>g|{nFPg0wp%} z-1Zyy&XHZ{Yzl{K=RV3z_X|lhoIt2Gb8N2$o8&kmD~+~_=bx#j2C69u?-)?UB%WYO z;4xTx601@CrS6ueGK&6K~KuV#~`e$lH%QE;m5% zLN_ka8;}PyCcDd1jCo$LCM)#LdZ)+hOj;rQ#YQffGwiePUm?YKbU%_kC1uI#q9jei z^BD(J5M4HOhXkN``H^0-#Pyp*KRs&sDft49$2Kw38_X)_xUo0gJSEYE{ZE76lN>_` z6%Wxx+S>Od!Wef&3`q;)5j7Lt1)DNX8BCB~@jgfFheM85&|3ph~W(3zxo;qHXgx5URU@s*(XEtb@)wheB$a8w;Og)B0=3CkI^>nrBz+Jl``-v|>+ znWL&#Lq%^1`jnwWe|{Ld5RqJh?gfljeoTg$MRi>%%eHs8@F>soa3#ad`VCT#&UFh{ z)76y%x)O}BaM}DZIiGw}1K^xlPAT!m-<~Hp28*`jYz~DZdMp zAGk7&TM&2$2ZaykqH$H1ofx^&yO}CA<=t(Z(t<^AfgL$A)8FxCPYqBI=r=rz!%kjf zaP2pg>B{lL?GYWg^5PCml)Lw2z6;kF_ bhZM_>xsm^Pp{4NYg28jz;qiioc9S}e z5slX z(JetY%_3#5Zxiktg-K(Yv}cc((tF71Oy|77O)9gPrrV}v83`)G$3`gBwbgQQ6^}LV zqB{&A%bP71n7dsKo*%2q3akC-VQPL^=VSXD@mX$t^9@1+9q^o>^FuDyjlWBbba(Q2 zaeAeP2rH!H6L?zxr>UGGKzIC(mTXJbjohcpDb?jR)LA)X#*m27wM-&U#_jS2FN6v{ zgyPL?%ywk-ldWQiXdTX{JVT$khS`E>zZbHEeVcM#@J*yLr%W*id!_-`Y<|nO7z0gd|G33R!2s3XzZFBl;oX#qa})q zq)3I48wM@Np3)ee8YY-?A36(?cjDY0?N=eIR;cUJ+flrStJhJsUc1=(kPv=pvDWhn zujMWV;GVV1XUR{uJkOB)cfD1>orH~31>@$lZx;8tk(ImqjoLxE`iS$qJ%Z|cmW>&h z2XNIMKy474G(MeEq?l+ng034BvE5Q{bNXm}x#7BC&~k#>>~g}P@!s8+q<8yI!-G~x zypguytp3@0+8kcxV@I;3&^N)kYkOBOTKOmhpehpEQVLZx5cY#z?gRXVk_%PBP@B9g zC1?X$O$y1aW{0hx(jvcNIJ;gelR&m=2?5m>E^daiXkt}Ab>TY5rspXl;bon6BRTUb zGUs}FLiFZ(jC$WoK;yScmpJ$JEKEQQtiZu$k9lPMdGY(i4~PK%;lZAMzDIF*?;wBo zz#zP9P$2fGjWr7Z+A+(*9E^}NYycg@dpZDM;GnR<;_f3G?R(}rgy<}!uc?JED z2~2_jkedSl;BUyx2_M@18>YlL2X{8xk0HFIo2XK9bT_%o=f5CdY`@3ULe_#I&a@`p%pRb|^fM^B) z;QR_&N@V_#?!WyrHAW!Kt&pGZ{~r=PU?#IT;X7$eX2x%2R!ZE}{K7;d;f7}4g*;I1 ziGov*Gc=7R(uUwyY1R?hb-y43@$TNP{(*QbA&B7T`@K>)z!!y<8vK+70JRnLe<dOa~TaqwSqE7gA^d0Qe7N C;SiPp literal 0 HcmV?d00001 diff --git a/docs/usergd.html b/docs/usergd.html new file mode 100644 index 0000000..f84766b --- /dev/null +++ b/docs/usergd.html @@ -0,0 +1,872 @@ + + + + + + + +DELAUNAYSPARSE + + + +
+ + + +
+

Overview

+

+The package +DELAUNAYSPARSE +(ACM TOMS Algorithm 1012) contains serial and parallel codes, written in +FORTRAN 2003 with OpenMP 4.5, for performing +interpolation in medium to high dimensions via a sparse subset of the +Delaunay triangulation. +In addition to the original FORTRAN source code, this site can +be used to download a Python 3.6+ wrapper and C/C++ +bindings for DELAUNAYSPARSE. +Note that each of the three downloads is self-contained, with the +Python wrapper and C bindings each containing +a subset of the FORTRAN as is needed to build and run +their respective functionalities. +Command line drivers, which accept formatted data files, are also available +by downloading the original FORTRAN source code. +

+

+The serial driver subroutine is DELAUNAYSPARSES +and the parallel driver subroutine is DELAUNAYSPARSEP. +The subroutines DELAUNAYSPARSE{S|P} use the module +REAL_PRECISION from HOMPACK90 +(ACM TOMS Algorithm 777) for specifying the real data type, +and the subroutine DWNNLS from SLATEC +to compute projections onto the convex hull during extrapolation. +The master module DELSPARSE_MOD includes the +REAL_PRECISION module and interface blocks for both +DELAUNAYSPARSES and DELAUNAYSPARSEP, as well as +an interface block for the updated SLATEC subroutine +DWNNLS, which may be of separate interest. +Comments at the beginning of the driver subroutines +DELAUNAYSPARSE{S|P} document the arguments and usage, +and examples demonstrating their usage are provided in the +sample programs samples.f90 and samplep.f90. +

+

+The physical organization of the main +TOMS source download into files is as follows. +Further details on using the Python wrapper +and C bindings downloads are given in their +respective README files, which are included in the downloads. + +

    +
  • The file delsparse.f90 contains the module + REAL_PRECISION, DELSPARSE_MOD, and + the driver subroutines DELAUNAYSPARSES, and + DELAUNAYSPARSEP.
    • +
  • The file slatec.f contains the subroutine + DWNNLS and its dependencies from the SLATEC + library. This library has been slightly modified to + comply with the modern Fortran standards. Additionally, legacy + implementations of the BLAS subroutines DROTM + and DTROMG have been included under different names to + avoid dependency issues. Depending on your compiler, you may still + receive warnings related to obsolete features.
    • +
  • The file samples.f90 contains a sample command line program + demonstrating the usage of DELAUNAYSPARSES, with optional + arguments. This program can also be used to use DELAUNAYSPARSES + on formatted data files from the command line.
    • +
  • The file samplep.f90 contains a sample command line program + demonstrating the usage of DELAUNAYSPARSEP, with optional + arguments. This program can also be used to use DELAUNAYSPARSEP + on formatted data files from the command line.
    • +
  • The file test_install.f90 contains a simple test program + that checks whether the installation of DELAUNAYSPARSE appears correct, + based on the output to a small interpolation/extrapolation problem.
    • +
  • The file sample_input2d.dat contains a sample 2-dimensional + input data set for samples.f90 and samplep.f90, + coming from the + VarSys project at Virginia Tech.
    • +
  • The file sample_input4d.dat contains a sample 4-dimensional + input data set for samples.f90 and samplep.f90, + coming from the + VarSys project at Virginia Tech.
    • +
  • The files lapack.f and blas.f contain all + LAPACK and BLAS + subroutines that are referenced (both directly and indirectly) in + DELAUNAYSPARSE.
    • +
  • A sample GNU Makefile is provided. +
+

+ +

+To check that the installation of DELAUNAYSPARSES and +DELAUNAYSPARSEP is correct, assuming that your Fortran compiler +allows mixing fixed format .f and free format .f90 +files in the same compile command, use the command +

+ +
+$FORT $OPTS delsparse.f90 slatec.f lapack.f blas.f test_install.f90 \
+  -o test_install $LIBS
+
+ +

+where $FORT is a FORTRAN 2003 compliant compiler +supporting OpenMP 4.5, $OPTS is a list of compiler +options, and $LIBS is a list of flags to link the +BLAS and LAPACK libraries, if those exist on your +system (in which case the files blas.f and lapack.f +can be omitted from the compile command). To run the parallel code, +$OPTS must include the compiler option for OpenMP. +

+ +

+Then run the tests using +

+ +
+./test_install
+
+ +

+To compile and link the sample main programs sample{s|p}.f90, use +

+ +
+$FORT $OPTS delsparse.f90 slatec.f lapack.f blas.f sample{s|p}.f90 \
+  -o sample{s|p} $LIBS
+
+ +

+similar to above. To run a sample main program, use +

+ +
+./sample{s|p} sample_input{2|4}d.dat
+
+ +

+where sample_input{2|4}d.dat could be replaced by any other +similarly formatted data file. +

+ + +

Usage Information for DELAUNAYSPARSE

+ +

+DELAUNAYSPARSE solves the multivariate interpolation problem: +

+

+Given a set of N points PTS and a set of M +interpolation points Q in R^D, for each interpolation +point Q_i in Q, identify the set +of D+1 data points in PTS that are the vertices of a +Delaunay simplex containing Q_i. +

+

+These vertices can be used to calculate the Delaunay interpolant using +a piecewise linear model. +

+

+For more information on the underlying algorithm, see +

+    @inproceedings{algorithm,
+        author={Chang, Tyler H. and Watson, Layne T. and Lux, Thomas C. H. and
+                Li, Bo and Xu, Li and Butt, Ali R. and Cameron, Kirk W. and
+                Hong, Yili},
+        title={A polynomial time algorithm for multivariate interpolation in
+               arbitrary dimension via the {D}elaunay triangulation},
+        year={2018},
+        month={mar},
+        booktitle={Proc. ACMSE 2018 Conference (ACMSE 18)},
+        publisher={ACM},
+        location={Richmond, KY},
+        doi={10.1145/3190645.3190680}
+    }
+
+

+

+For more information on this software, see +

+    @article{toms1012,
+        author={Chang, Tyler H. and Watson, Layne T. and Lux, Thomas C. H.
+                and Butt, Ali R. and Cameron, Kirk W. and Hong, Yili},
+        title={Algorithm 1012: {DELAUNAYSPARSE}: Interpolation via a sparse
+               subset of the {D}elaunay triangulation in medium to high
+               dimensions},
+        year={2020},
+        volume={46},
+        number={4},
+        articleno={38},
+        nopages={20},
+        doi={10.1145/3422818}
+    }
+
+

+

+DELAUNAYSPARSE contains a Fortran module +

    +
  • delsparse;
    • +
+as well as C bindings +
    +
  • delsparsec;
    • +
+two command-line drivers +
    +
  • delsparses and
    • +
  • delsparsep;
    • +
+ +and a Python 3 wrapper +
    +
  • python.
    • +
+

+

+These interfaces are described in the following sections. +

+ +

Fortran interface

+

+DELAUNAYSPARSE is written in Fortran 2003, and this is its native interface. +The Fortran interface contains two drivers: +

    +
  • DELAUNAYSPARSES (serial driver) and
    • +
  • DELAUNAYSPARSEP (OpenMP parallel driver).
    • +
+

+ +

DELAUNAYSPARSES

+

+The interface for DELAUNAYSPARSES is +

+SUBROUTINE DELAUNAYSPARSES( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR,     &
+                            INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, &
+                            IBUDGET, CHAIN, EXACT                      )
+
+

+

+Each of the above parameters is described below. +

+

+On input: +

    +
  • D is the dimension of the space for PTS and + Q.
    • +
  • N is the number of data points in PTS.
    • +
  • PTS(1:D,1:N) is a real valued matrix with N + columns, each containing the coordinates of a single data point in + R^D.
    • +
  • M is the number of interpolation points in Q.
    • +
  • Q(1:D,1:M) is a real valued matrix with M columns, + each containing the coordinates of a single interpolation point in + R^D.
    • +
+

+

+On output: +

    +
  • PTS and Q have been rescaled and shifted. + All the data points in PTS are now contained in the unit + hyperball in R^D, and the points in Q + have been shifted and scaled accordingly in relation to PTS. +
    • +
  • SIMPS(1:D+1,1:M) contains the D+1 integer + indices (corresponding to columns in PTS) for the + D+1 vertices of the Delaunay simplex containing each + interpolation point in Q.
    • +
  • WEIGHTS(1:D+1,1:M) contains the D+1 real-valued + weights for expressing each point in Q as a convex combination + of the D+1 corresponding vertices in SIMPS.
    • +
  • IERR(1:M) contains integer valued error flags associated with + the computation of each of the M interpolation points in + Q. The error codes are: +

    + Codes 0, 1, 2 are expected to occur during normal execution. +
      +
    • 00 : Succesful interpolation.
      • +
    • 01 : Succesful extrapolation (up to the allowed extrapolation + distance).
      • +
    • 02 : This point was outside the allowed extrapolation distance; the + corresponding entries in SIMPS and WEIGHTS contain zero values.
      • +
    + + Error codes 10--28 indicate that one or more inputs contain illegal + values or are incompatible with each other. +
      +
    • 10 : The dimension D must be positive.
      • +
    • 11 : Too few data points to construct a triangulation (i.e., + N < D+1).
      • +
    • 12 : No interpolation points given (i.e., M < 1).
      • +
    • 13 : The first dimension of PTS does not agree with the + dimension D.
      • +
    • 14 : The second dimension of PTS does not agree with the + number of points N.
      • +
    • 15 : The first dimension of Q does not agree with the + dimension D.
      • +
    • 16 : The second dimension of Q does not agree with the + number of interpolation points M.
      • +
    • 17 : The first dimension of the output array SIMPS does + not match the number of vertices needed for a D-simplex + (D+1).
      • +
    • 18 : The second dimension of the output array SIMPS does + not match the number of interpolation points M.
      • +
    • 19 : The first dimension of the output array WEIGHTS does + not match the number of vertices for a a D-simplex + (D+1).
      • +
    • 20 : The second dimension of the output array WEIGHTS + does not match the number of interpolation points M.
      • +
    • 21 : The size of the error array IERR does not match the + number of interpolation points M.
      • +
    • 22 : INTERP_IN cannot be present without + INTERP_OUT or vice versa.
      • +
    • 23 : The first dimension of INTERP_IN does not match the + first dimension of INTERP_OUT.
      • +
    • 24 : The second dimension of INTERP_IN does not match the + number of data points PTS.
      • +
    • 25 : The second dimension of INTERP_OUT does not match the + number of interpolation points M.
      • +
    • 26 : The budget supplied in IBUDGET does not contain a + positive integer.
      • +
    • 27 : The extrapolation distance supplied in EXTRAP cannot + be negative.
      • +
    • 28 : The size of the RNORM output array does not match the + number of interpolation points M.
      • +
    + + The errors 30, 31 typically indicate that DELAUNAYSPARSE has been given + an unclean dataset. These errors can be fixed by preprocessing your + data (remove duplicate points and apply PCA or other dimension reduction + technique). +
      +
    • 30 : Two or more points in the data set PTS are too close + together with respect to the working precision (EPS), + which would result in a numerically degenerate simplex.
      • +
    • 31 : All the data points in PTS lie in some lower + dimensional linear manifold (up to the working precision), and no valid + triangulation exists.
      • +
    + + The error code 40 occurs when another earlier error prevented this point + from ever being evaluated. +
      +
    • 40 : An error caused DELAUNAYSPARSES to terminate before + this value could be computed. Note: The corresponding entries in + SIMPS and WEIGHTS may contain garbage values. +
      • +
    + + The error code 50 corresponds to allocation of the internal WORK array. + Check your systems internal memory settings and limits, in relation + to the problem size and DELAUNAYSPARSE's space requirements (see TOMS + Alg. paper for more details on DELAUNAYSPARSE's space requirements). +
      +
    • 50 : A memory allocation error occurred while allocating the work array + WORK.
      • +
    + + The errors 60, 61 should not occur with the default settings. If one of + these errors is observed, then it is likely that either the value of + the optional inputs IBUDGET or EPS has been + adjusted in a way that is unwise, or there may be another issue with the + problem settings, which is manifesting in an unusual way. +
      +
    • 60 : The budget was exceeded before the algorithm converged on this + value. If the dimension is high, try increasing IBUDGET. + This error can also be caused by a working precision EPS + that is too small for the conditioning of the problem.
      • +
    • 61 : A value that was judged appropriate later caused LAPACK to + encounter a singularity. Try increasing the value of EPS. +
      • +
    + + The errors 70--72 were caused by the DWNNLS library from SLATEC, which + is only used during extrapolation. Note that there is a known issue + with this library, when it is linked against included public-domain + copy of BLAS/LAPACK, instead of an installed version + (i.e., -lblas -llapack). +
      +
    • 70 : Allocation error for the extrapolation work arrays.
      • +
    • 71 : The SLATEC subroutine DWNNLS failed to converge + during the projection of an extrapolation point onto the convex hull. +
      • +
    • 72 : The SLATEC subroutine DWNNLS has reported a usage + error.
      • +
    + + The errors 72, 80--83 should never occur, and likely indicate a + compiler bug or hardware failure. +
      +
    • 80 : The LAPACK subroutine DGEQP3 has reported an illegal + value.
      • +
    • 81 : The LAPACK subroutine DGETRF has reported an illegal + value.
      • +
    • 82 : The LAPACK subroutine DGETRS has reported an illegal + value.
      • +
    • 83 : The LAPACK subroutine DORMQR has reported an illegal + value.
      • +
    +
+

+

+Optional arguments: +

    +
  • INTERP_IN(1:IR,1:N) contains real valued response vectors for + each of the data points in PTS on input. The first dimension + of INTERP_IN is inferred to be the dimension of these + response vectors, and the second dimension must match N. + If present, the response values will be computed for each interpolation + point in Q, and stored in INTERP_OUT, + which therefore must also be present. If both INTERP_IN and + INTERP_OUT are omitted, only the containing simplices and + convex combination weights are returned.
    • +
  • INTERP_OUT(1:IR,1:M) contains real valued response vectors + for each interpolation point in Q on output. The first + dimension of INTERP_OUT must match the first dimension of + INTERP_IN, and the second dimension must match M. + If present, the response values at each interpolation point are computed + as a convex combination of the response values (supplied in + INTERP_IN) at the vertices of a Delaunay simplex containing + that interpolation point. Therefore, if INTERP_OUT is + present, then INTERP_IN must also be present. If both are + omitted, only the simplices and convex combination weights are returned. +
    • +
  • EPS contains the real working precision for the problem on + input. By default, EPS is assigned \sqrt{\mu} + where \mu denotes the unit roundoff for the machine. In + general, any values that differ by less than EPS are judged + as equal, and any weights that are greater than -EPS are + judged as nonnegative. EPS cannot take a value less than the + default value of \sqrt{\mu}. If any value less than + \sqrt{\mu} is supplied, the default value will be used + instead automatically.
    • +
  • EXTRAP contains the real maximum extrapolation distance + (relative to the diameter of PTS) on input. Interpolation + at a point outside the convex hull of PTS is done by + projecting that point onto the convex hull, and then doing normal + Delaunay interpolation at that projection. Interpolation at any point + in Q that is more than EXTRAP * DIAMETER(PTS) + units outside the convex hull of PTS will not be done and + an error code of 2 will be returned. Note that computing + the projection can be expensive. Setting EXTRAP=0 will + cause all extrapolation points to be ignored without ever computing a + projection. By default, EXTRAP=0.1 + (extrapolate by up to 10% of the diameter of PTS).
    • +
  • RNORM(1:M) contains the real unscaled projection (2-norm) + distances from any projection computations on output. If not present, + these distances are still computed for each extrapolation point, but are + never returned.
    • +
  • IBUDGET on input contains the integer budget for performing + flips while iterating toward the simplex containing each interpolation + point in Q. This prevents DELAUNAYSPARSES from + falling into an infinite loop when an inappropriate value of + EPS is given with respect to the problem conditioning. + By default, IBUDGET=50000. However, for extremely + high-dimensional problems and pathological inputs, the default value + may be insufficient.
    • +
  • CHAIN is a logical input argument that determines whether a + new first simplex should be constructed for each interpolation point + (CHAIN=.FALSE.), or whether the simplex walks should be + "daisy-chained." By default, CHAIN=.FALSE. Setting + CHAIN=.TRUE. is generally not recommended, unless the size + of the triangulation is relatively small or the interpolation points are + known to be tightly clustered.
    • +
  • EXACT is a logical input argument that determines whether + the exact diameter should be computed and whether a check for duplicate + data points should be performed in advance. When + EXACT=.FALSE., the diameter of PTS is + approximated by twice the distance from the barycenter of PTS + to the farthest point in PTS, and no check is done to find + the closest pair of points, which could result in hard to find bugs later + on. When EXACT=.TRUE., the exact diameter is computed and + an error is returned whenever PTS contains duplicate values up to the + precision EPS. By default EXACT=.TRUE., but + setting EXACT=.FALSE. could result in significant speedup + when N is large.
    • It is strongly recommended that most + users leave EXACT=.TRUE., as setting + EXACT=.FALSE. could result in input errors that are difficult + to identify. Also, the diameter approximation could be wrong by up to + a factor of two. +
+

+

+Subroutines and functions directly referenced from BLAS are +

    +
  • DDOT,
    • +
  • DGEMV,
    • +
  • DNRM2,
    • +
  • DTRSM,
    • +
+and from LAPACK are +
    +
  • DGEQP3,
    • +
  • DGETRF,
    • +
  • DGETRS,
    • +
  • DORMQR.
    • +
+

+

+The SLATEC subroutine +

    +
  • DWNNLS is also directly referenced.
    • +
+DWNNLS and all its SLATEC dependencies have been slightly edited +to comply with the Fortran 2008 standard, with all print statements and +references to stderr being commented out. For a reference to DWNNLS, +see ACM TOMS Algorithm 587 (Hanson and Haskell). +The module REAL_PRECISION from HOMPACK90 (ACM TOMS Algorithm 777) +is used for the real data type. The REAL_PRECISION module, +DELAUNAYSPARSES, and DWNNLS and its dependencies +comply with the Fortran 2008 standard. +

+ +

DELAUNAYSPARSEP

+

+The interface for DELAUNAYSPARSEP is +

+    SUBROUTINE DELAUNAYSPARSEP( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR,     &
+                                INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, &
+                                IBUDGET, CHAIN, EXACT, PMODE               )
+
+

+

+Each of the above parameters is described below. +

+

+On input: +

    +
  • D is the dimension of the space for PTS and + Q.
    • +
  • N is the number of data points in PTS.
    • +
  • PTS(1:D,1:N) is a real valued matrix with N + columns, each containing the coordinates of a single data point in + R^D.
    • +
  • M is the number of interpolation points in Q.
    • +
  • Q(1:D,1:M) is a real valued matrix with M columns, + each containing the coordinates of a single interpolation point in + R^D.
    • +
+

+

+On output: +

    +
  • PTS and Q have been rescaled and shifted. + All the data points in PTS are now contained in the unit + hyperball in R^D, and the points in Q + have been shifted and scaled accordingly in relation to PTS. +
    • +
  • SIMPS(1:D+1,1:M) contains the D+1 integer + indices (corresponding to columns in PTS) for the + D+1 vertices of the Delaunay simplex containing each + interpolation point in Q.
    • +
  • WEIGHTS(1:D+1,1:M) contains the D+1 real-valued + weights for expressing each point in Q as a convex combination + of the D+1 corresponding vertices in SIMPS.
    • +
  • IERR(1:M) contains integer valued error flags associated with + the computation of each of the M interpolation points in + Q. The error codes are: +

    + Codes 0, 1, 2 are expected to occur during normal execution. +
      +
    • 00 : Succesful interpolation.
      • +
    • 01 : Succesful extrapolation (up to the allowed extrapolation + distance).
      • +
    • 02 : This point was outside the allowed extrapolation distance; the + corresponding entries in SIMPS and WEIGHTS contain zero values.
      • +
    + + Error codes 10--28 indicate that one or more inputs contain illegal + values or are incompatible with each other. +
      +
    • 10 : The dimension D must be positive.
      • +
    • 11 : Too few data points to construct a triangulation (i.e., + N < D+1).
      • +
    • 12 : No interpolation points given (i.e., M < 1).
      • +
    • 13 : The first dimension of PTS does not agree with the + dimension D.
      • +
    • 14 : The second dimension of PTS does not agree with the + number of points N.
      • +
    • 15 : The first dimension of Q does not agree with the + dimension D.
      • +
    • 16 : The second dimension of Q does not agree with the + number of interpolation points M.
      • +
    • 17 : The first dimension of the output array SIMPS does + not match the number of vertices needed for a D-simplex + (D+1).
      • +
    • 18 : The second dimension of the output array SIMPS does + not match the number of interpolation points M.
      • +
    • 19 : The first dimension of the output array WEIGHTS does + not match the number of vertices for a a D-simplex + (D+1).
      • +
    • 20 : The second dimension of the output array WEIGHTS + does not match the number of interpolation points M.
      • +
    • 21 : The size of the error array IERR does not match the + number of interpolation points M.
      • +
    • 22 : INTERP_IN cannot be present without + INTERP_OUT or vice versa.
      • +
    • 23 : The first dimension of INTERP_IN does not match the + first dimension of INTERP_OUT.
      • +
    • 24 : The second dimension of INTERP_IN does not match the + number of data points PTS.
      • +
    • 25 : The second dimension of INTERP_OUT does not match the + number of interpolation points M.
      • +
    • 26 : The budget supplied in IBUDGET does not contain a + positive integer.
      • +
    • 27 : The extrapolation distance supplied in EXTRAP cannot + be negative.
      • +
    • 28 : The size of the RNORM output array does not match the + number of interpolation points M.
      • +
    + + The errors 30, 31 typically indicate that DELAUNAYSPARSE has been given + an unclean dataset. These errors can be fixed by preprocessing your + data (remove duplicate points and apply PCA or other dimension reduction + technique). +
      +
    • 30 : Two or more points in the data set PTS are too close + together with respect to the working precision (EPS), + which would result in a numerically degenerate simplex.
      • +
    • 31 : All the data points in PTS lie in some lower + dimensional linear manifold (up to the working precision), and no valid + triangulation exists.
      • +
    + + The error code 40 occurs when another earlier error prevented this point + from ever being evaluated. +
      +
    • 40 : An error caused DELAUNAYSPARSEP to terminate before + this value could be computed. Note: The corresponding entries in + SIMPS and WEIGHTS may contain garbage values. +
      • +
    + + The error code 50 corresponds to allocation of the internal WORK array. + Check your systems internal memory settings and limits, in relation + to the problem size and DELAUNAYSPARSE's space requirements (see TOMS + Alg. paper for more details on DELAUNAYSPARSE's space requirements). +
      +
    • 50 : A memory allocation error occurred while allocating the work array + WORK.
      • +
    + + The errors 60, 61 should not occur with the default settings. If one of + these errors is observed, then it is likely that either the value of + the optional inputs IBUDGET or EPS has been + adjusted in a way that is unwise, or there may be another issue with the + problem settings, which is manifesting in an unusual way. +
      +
    • 60 : The budget was exceeded before the algorithm converged on this + value. If the dimension is high, try increasing IBUDGET. + This error can also be caused by a working precision EPS + that is too small for the conditioning of the problem.
      • +
    • 61 : A value that was judged appropriate later caused LAPACK to + encounter a singularity. Try increasing the value of EPS. +
      • +
    + + The errors 70--72 were caused by the DWNNLS library from SLATEC, which + is only used during extrapolation. Note that there is a known issue + with this library, when it is linked against included public-domain + copy of BLAS/LAPACK, instead of an installed version + (i.e., -lblas -llapack). +
      +
    • 70 : Allocation error for the extrapolation work arrays.
      • +
    • 71 : The SLATEC subroutine DWNNLS failed to converge + during the projection of an extrapolation point onto the convex hull. +
      • +
    • 72 : The SLATEC subroutine DWNNLS has reported a usage + error.
      • +
    + + The errors 72, 80--83 should never occur, and likely indicate a + compiler bug or hardware failure. +
      +
    • 80 : The LAPACK subroutine DGEQP3 has reported an illegal + value.
      • +
    • 81 : The LAPACK subroutine DGETRF has reported an illegal + value.
      • +
    • 82 : The LAPACK subroutine DGETRS has reported an illegal + value.
      • +
    • 83 : The LAPACK subroutine DORMQR has reported an illegal + value.
      • +
    + + The error code 90 is unique to DELAUNAYSPARSEP. +
      +
    • 90 : The value of PMODE is not valid.
      • +
    +
+

+

+Optional arguments: +

    +
  • INTERP_IN(1:IR,1:N) contains real valued response vectors for + each of the data points in PTS on input. The first dimension + of INTERP_IN is inferred to be the dimension of these + response vectors, and the second dimension must match N. + If present, the response values will be computed for each interpolation + point in Q, and stored in INTERP_OUT, + which therefore must also be present. If both INTERP_IN and + INTERP_OUT are omitted, only the containing simplices and + convex combination weights are returned.
    • +
  • INTERP_OUT(1:IR,1:M) contains real valued response vectors + for each interpolation point in Q on output. The first + dimension of INTERP_OUT must match the first dimension of + INTERP_IN, and the second dimension must match M. + If present, the response values at each interpolation point are computed + as a convex combination of the response values (supplied in + INTERP_IN) at the vertices of a Delaunay simplex containing + that interpolation point. Therefore, if INTERP_OUT is + present, then INTERP_IN must also be present. If both are + omitted, only the simplices and convex combination weights are returned. +
    • +
  • EPS contains the real working precision for the problem on + input. By default, EPS is assigned \sqrt{\mu} + where \mu denotes the unit roundoff for the machine. In + general, any values that differ by less than EPS are judged + as equal, and any weights that are greater than -EPS are + judged as nonnegative. EPS cannot take a value less than the + default value of \sqrt{\mu}. If any value less than + \sqrt{\mu} is supplied, the default value will be used + instead automatically.
    • +
  • EXTRAP contains the real maximum extrapolation distance + (relative to the diameter of PTS) on input. Interpolation + at a point outside the convex hull of PTS is done by + projecting that point onto the convex hull, and then doing normal + Delaunay interpolation at that projection. Interpolation at any point + in Q that is more than EXTRAP * DIAMETER(PTS) + units outside the convex hull of PTS will not be done and + an error code of 2 will be returned. Note that computing + the projection can be expensive. Setting EXTRAP=0 will + cause all extrapolation points to be ignored without ever computing a + projection. By default, EXTRAP=0.1 + (extrapolate by up to 10% of the diameter of PTS).
    • +
  • RNORM(1:M) contains the real unscaled projection (2-norm) + distances from any projection computations on output. If not present, + these distances are still computed for each extrapolation point, but are + never returned.
    • +
  • IBUDGET on input contains the integer budget for performing + flips while iterating toward the simplex containing each interpolation + point in Q. This prevents DELAUNAYSPARSEP from + falling into an infinite loop when an inappropriate value of + EPS is given with respect to the problem conditioning. + By default, IBUDGET=50000. However, for extremely + high-dimensional problems and pathological inputs, the default value + may be insufficient.
    • +
  • CHAIN is a logical input argument that determines whether a + new first simplex should be constructed for each interpolation point + (CHAIN=.FALSE.), or whether the simplex walks should be + "daisy-chained." By default, CHAIN=.FALSE. Setting + CHAIN=.TRUE. is generally not recommended, unless the size + of the triangulation is relatively small or the interpolation points are + known to be tightly clustered.
    • +
  • EXACT is a logical input argument that determines whether + the exact diameter should be computed and whether a check for duplicate + data points should be performed in advance. When + EXACT=.FALSE., the diameter of PTS is + approximated by twice the distance from the barycenter of PTS + to the farthest point in PTS, and no check is done to find + the closest pair of points, which could result in hard to find bugs later + on. When EXACT=.TRUE., the exact diameter is computed and + an error is returned whenever PTS contains duplicate values up to the + precision EPS. By default EXACT=.TRUE., but + setting EXACT=.FALSE. could result in significant speedup + when N is large.
    • It is strongly recommended that most + users leave EXACT=.TRUE., as setting + EXACT=.FALSE. could result in input errors that are difficult + to identify. Also, the diameter approximation could be wrong by up to + a factor of two. +
  • PMODE is an integer specifying the level of parallelism to + be exploited. +
      +
    • If PMODE = 1, then parallelism is exploited at the + level of the loop over all interpolation points (Level 1 + parallelism).
      • +
    • If PMODE = 2, then parallelism is exploited at the + level of the loops over data points when constructing/flipping + simplices (Level 2 parallelism).
      • +
    • If PMODE = 3, then parallelism is exploited at both + levels. Note: this implies that the total number of threads active + at any time could be up to OMP_NUM_THREADS^2. + By default, PMODE is set to 1 if there + is more than 1 interpolation point and 2 otherwise. +
      • +
    • +
+

+

+Subroutines and functions directly referenced from BLAS are +

    +
  • DDOT,
    • +
  • DGEMV,
    • +
  • DNRM2,
    • +
  • DTRSM,
    • +
+and from LAPACK are +
    +
  • DGEQP3,
    • +
  • DGETRF,
    • +
  • DGETRS,
    • +
  • DORMQR.
    • +
+

+

+The SLATEC subroutine +

    +
  • DWNNLS is also directly referenced.
    • +
+DWNNLS and all its SLATEC dependencies have been slightly edited +to comply with the Fortran 2008 standard, with all print statements and +references to stderr being commented out. For a reference to DWNNLS, +see ACM TOMS Algorithm 587 (Hanson and Haskell). +The module REAL_PRECISION from HOMPACK90 (ACM TOMS Algorithm 777) +is used for the real data type. The REAL_PRECISION module, +DELAUNAYSPARSEP, and DWNNLS and its dependencies +comply with the Fortran 2008 standard. +

+ +
+ +

+Notes: DELAUNAYSPARSE is available free of charge via a permissive +MIT LICENSE. +

+
+ + + + + +
+ + diff --git a/python/LICENSE b/python/LICENSE new file mode 100644 index 0000000..00ce8f0 --- /dev/null +++ b/python/LICENSE @@ -0,0 +1,22 @@ +MIT License + +Copyright (c) 2020 Tyler H. Chang, Layne T. Watson, Thomas C. H. Lux, +Ali R. Butt, Kirk W. Cameron, and Yili Hong. + +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, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +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. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/python/README b/python/README new file mode 100644 index 0000000..f5bba7f --- /dev/null +++ b/python/README @@ -0,0 +1,44 @@ +A Python3 wrapper for the DELAUNAYSPARSE Fortran package. + + +REQUIREMENTS: + + Python3.6+ with numpy package installed. + A Fortran compiler that supports BIND(C) and compiling shared objects. + The Python wrapper builds ".so" objects, and therefore only supports + Mac and Linux systems. + +USAGE: + + Update the configuration of the machine-specific Fortran compiler + and BLAS / LAPACK link commands (or use local blas.f lapack.f) + in the file "delsparse.py". + + Now, in Python3.6+ code the Fortran package can be accessed by + + import delsparse + + with accompanying documentation built-in through the `help` command + + help(delsparse) + + and it is assumed that Fortran-contiguous NumPy arrays will be the + vessel for data entering and exiting the Fortran module. An example + Python script is provided in `example.py`. That script also defines a + convenience wrapper that converts C-style (row major) sets of points + into Fortran-style (column major) sets of points. + +CONTRIBUTORS: + + Thomas Lux, tchlux@vt.edu + Tyler Chang, tchang@anl.gov + +ACKNOWLEDGEMENT: + + This Python3 wrapper was partially generated using fmodpy. + + If you are interested in automatically generating Python wrappers for + modern Fortran code, please consider visiting: + + https://github.com/tchlux/fmodpy + diff --git a/python/delsparse.py b/python/delsparse.py new file mode 100644 index 0000000..e25564d --- /dev/null +++ b/python/delsparse.py @@ -0,0 +1,759 @@ +# Python wrapper for DELAUNAYSPARSE using C interface. +import os +import ctypes +import numpy as np + +# -------------------------------------------------------------------- +# CONFIGURATION +# +fort_compiler = "gfortran" +shared_object_name = "delsparse_clib.so" +source_dir = os.path.abspath(os.path.dirname(__file__)) +path_to_lib = os.path.join(source_dir, shared_object_name) +compile_options = "-fPIC -shared -O3 -fopenmp -std=legacy" +# ^^ 'fPIC' and 'shared' are required. 'O3' is for speed and 'fopenmp' +# is necessary for supporting CPU parallelism during execution. +blas_lapack = "-lblas -llapack" +blas_lapack = "delsparse_src/blas.f delsparse_src/lapack.f" +# ^^ Use a local BLAS and LAPACK if available by commenting the second line +# above. The included "blas.f" and "lapack.f" are known to cause error 71 +# during extrapolation, but there is no known resolution. +ordered_dependencies = "delsparse_src/real_precision.f90 delsparse_src/slatec.f delsparse_src/delsparse.f90 delsparse_src/delsparse_bind_c.f90" +# +# -------------------------------------------------------------------- + + +# Try to import the existing object. If that fails, recompile and then try. +try: + delsparse_clib = ctypes.CDLL(path_to_lib) +except: + # Remove the shared object if it exists, because it is faulty. + if os.path.exists(shared_object_name): + os.remove(shared_object_name) + # Warn the user if they are using a local blas and lapack that + # this is known to cause extrapolation errors. + if (blas_lapack == "blas.f lapack.f"): + import warnings + warnings.warn("\n The provided 'blas.f' and 'lapack.f' are known to cause extrapolation errors."+ + "\n Consider using local libraries via compiler flags instead (see config"+ + "\n coments for 'blas_lapack' in '"+os.path.join(path_to_lib,__file__)+"').") + # Compile a new shared object. + command = " ".join([fort_compiler, compile_options, blas_lapack, + ordered_dependencies, "-o", path_to_lib]) + print("Running command") + print(" ", command) + os.system(command) + # Remove all ".mod" files that were created to reduce clutter. + all_mods = [f for f in os.listdir(os.curdir) if f[-4:] == ".mod"] + for m in all_mods: os.remove(m) + +# Import the shared object file as a C library with ctypes. +delsparse_clib = ctypes.CDLL(path_to_lib) + +def delaunaysparses(d, n, pts, m, q, simps, weights, ierr, interp_in=None, interp_out=None, eps=None, extrap=None, rnorm=None, ibudget=None, chain=None, exact=None): + '''! This is a serial implementation of an algorithm for efficiently performing +! interpolation in R^D via the Delaunay triangulation. The algorithm is fully +! described and analyzed in +! +! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. +! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate +! interpolation in arbitrary dimension via the Delaunay triangulation. In +! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, +! USA. Article 12, 8 pages. +! +! +! On input: +! +! D is the dimension of the space for PTS and Q. +! +! N is the number of data points in PTS. +! +! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the +! coordinates of a single data point in R^D. +! +! M is the number of interpolation points in Q. +! +! Q(1:D,1:M) is a real valued matrix with M columns, each containing the +! coordinates of a single interpolation point in R^D. +! +! +! On output: +! +! PTS and Q have been rescaled and shifted. All the data points in PTS +! are now contained in the unit hyperball in R^D, and the points in Q +! have been shifted and scaled accordingly in relation to PTS. +! +! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns +! in PTS) for the D+1 vertices of the Delaunay simplex containing each +! interpolation point in Q. +! +! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each +! point in Q as a convex combination of the D+1 corresponding vertices +! in SIMPS. +! +! IERR(1:M) contains integer valued error flags associated with the +! computation of each of the M interpolation points in Q. The error +! codes are: +! +! 00 : Succesful interpolation. +! 01 : Succesful extrapolation (up to the allowed extrapolation distance). +! 02 : This point was outside the allowed extrapolation distance; the +! corresponding entries in SIMPS and WEIGHTS contain zero values. +! +! 10 : The dimension D must be positive. +! 11 : Too few data points to construct a triangulation (i.e., N < D+1). +! 12 : No interpolation points given (i.e., M < 1). +! 13 : The first dimension of PTS does not agree with the dimension D. +! 14 : The second dimension of PTS does not agree with the number of points N. +! 15 : The first dimension of Q does not agree with the dimension D. +! 16 : The second dimension of Q does not agree with the number of +! interpolation points M. +! 17 : The first dimension of the output array SIMPS does not match the number +! of vertices needed for a D-simplex (D+1). +! 18 : The second dimension of the output array SIMPS does not match the +! number of interpolation points M. +! 19 : The first dimension of the output array WEIGHTS does not match the +! number of vertices for a a D-simplex (D+1). +! 20 : The second dimension of the output array WEIGHTS does not match the +! number of interpolation points M. +! 21 : The size of the error array IERR does not match the number of +! interpolation points M. +! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. +! 23 : The first dimension of INTERP_IN does not match the first +! dimension of INTERP_OUT. +! 24 : The second dimension of INTERP_IN does not match the number of +! data points PTS. +! 25 : The second dimension of INTERP_OUT does not match the number of +! interpolation points M. +! 26 : The budget supplied in IBUDGET does not contain a positive +! integer. +! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. +! 28 : The size of the RNORM output array does not match the number of +! interpolation points M. +! +! 30 : Two or more points in the data set PTS are too close together with +! respect to the working precision (EPS), which would result in a +! numerically degenerate simplex. +! 31 : All the data points in PTS lie in some lower dimensional linear +! manifold (up to the working precision), and no valid triangulation +! exists. +! 40 : An error caused DELAUNAYSPARSES to terminate before this value could +! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may +! contain garbage values. +! +! 50 : A memory allocation error occurred while allocating the work array +! WORK. +! +! 60 : The budget was exceeded before the algorithm converged on this +! value. If the dimension is high, try increasing IBUDGET. This +! error can also be caused by a working precision EPS that is too +! small for the conditioning of the problem. +! +! 61 : A value that was judged appropriate later caused LAPACK to encounter a +! singularity. Try increasing the value of EPS. +! +! 70 : Allocation error for the extrapolation work arrays. +! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection +! of an extrapolation point onto the convex hull. +! 72 : The SLATEC subroutine DWNNLS has reported a usage error. +! +! The errors 72, 80--83 should never occur, and likely indicate a +! compiler bug or hardware failure. +! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. +! 81 : The LAPACK subroutine DGETRF has reported an illegal value. +! 82 : The LAPACK subroutine DGETRS has reported an illegal value. +! 83 : The LAPACK subroutine DORMQR has reported an illegal value. +! +! +! Optional arguments: +! +! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of +! the data points in PTS on input. The first dimension of INTERP_IN is +! inferred to be the dimension of these response vectors, and the +! second dimension must match N. If present, the response values will +! be computed for each interpolation point in Q, and stored in INTERP_OUT, +! which therefore must also be present. If both INTERP_IN and INTERP_OUT +! are omitted, only the containing simplices and convex combination +! weights are returned. +! +! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each +! interpolation point in Q on output. The first dimension of INTERP_OUT +! must match the first dimension of INTERP_IN, and the second dimension +! must match M. If present, the response values at each interpolation +! point are computed as a convex combination of the response values +! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing +! that interpolation point. Therefore, if INTERP_OUT is present, then +! INTERP_IN must also be present. If both are omitted, only the +! simplices and convex combination weights are returned. +! +! EPS contains the real working precision for the problem on input. By default, +! EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff for the +! machine. In general, any values that differ by less than EPS are judged +! as equal, and any weights that are greater than -EPS are judged as +! nonnegative. EPS cannot take a value less than the default value of +! \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, the default +! value will be used instead automatically. +! +! EXTRAP contains the real maximum extrapolation distance (relative to the +! diameter of PTS) on input. Interpolation at a point outside the convex +! hull of PTS is done by projecting that point onto the convex hull, and +! then doing normal Delaunay interpolation at that projection. +! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) +! units outside the convex hull of PTS will not be done and an error code +! of 2 will be returned. Note that computing the projection can be +! expensive. Setting EXTRAP=0 will cause all extrapolation points to be +! ignored without ever computing a projection. By default, EXTRAP=0.1 +! (extrapolate by up to 10% of the diameter of PTS). +! +! RNORM(1:M) contains the real unscaled projection (2-norm) distances from +! any projection computations on output. If not present, these distances +! are still computed for each extrapolation point, but are never returned. +! +! IBUDGET on input contains the integer budget for performing flips while +! iterating toward the simplex containing each interpolation point in +! Q. This prevents DELAUNAYSPARSES from falling into an infinite loop when +! an inappropriate value of EPS is given with respect to the problem +! conditioning. By default, IBUDGET=50000. However, for extremely +! high-dimensional problems and pathological inputs, the default value +! may be insufficient. +! +! CHAIN is a logical input argument that determines whether a new first +! simplex should be constructed for each interpolation point +! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." +! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not +! recommended, unless the size of the triangulation is relatively small +! or the interpolation points are known to be tightly clustered. +! +! EXACT is a logical input argument that determines whether the exact +! diameter should be computed and whether a check for duplicate data +! points should be performed in advance. When EXACT=.FALSE., the +! diameter of PTS is approximated by twice the distance from the +! barycenter of PTS to the farthest point in PTS, and no check is +! done to find the closest pair of points, which could result in hard +! to find bugs later on. When EXACT=.TRUE., the exact diameter is +! computed and an error is returned whenever PTS contains duplicate +! values up to the precision EPS. By default EXACT=.TRUE., but setting +! EXACT=.FALSE. could result in significant speedup when N is large. +! It is strongly recommended that most users leave EXACT=.TRUE., as +! setting EXACT=.FALSE. could result in input errors that are difficult +! to identify. Also, the diameter approximation could be wrong by up to +! a factor of two. +! +! +! Subroutines and functions directly referenced from BLAS are +! DDOT, DGEMV, DNRM2, DTRSM, +! and from LAPACK are +! DGEQP3, DGETRF, DGETRS, DORMQR. +! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its +! SLATEC dependencies have been slightly edited to comply with the Fortran +! 2008 standard, with all print statements and references to stderr being +! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 +! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS +! Algorithm 777) is used for the real data type. The REAL_PRECISION module, +! DELAUNAYSPARSES, and DWNNLS and its dependencies comply with the Fortran +! 2008 standard. +! +! Primary Author: Tyler H. Chang +! Last Update: March, 2020 +!''' + + # Setting up "d" + d = ctypes.c_int(d) + + # Setting up "n" + n = ctypes.c_int(n) + + # Setting up "m" + m = ctypes.c_int(m) + + # Setting up "pts" + pts_local = np.asarray(pts, dtype=ctypes.c_double) + pts_dim_1 = ctypes.c_int(pts_local.shape[0]) + pts_dim_2 = ctypes.c_int(pts_local.shape[1]) + + # Setting up "q" + q_local = np.asarray(q, dtype=ctypes.c_double) + q_dim_1 = ctypes.c_int(q_local.shape[0]) + q_dim_2 = ctypes.c_int(q_local.shape[1]) + + # Setting up "simps" + simps_local = np.asarray(simps, dtype=ctypes.c_int) + simps_dim_1 = ctypes.c_int(simps_local.shape[0]) + simps_dim_2 = ctypes.c_int(simps_local.shape[1]) + + # Setting up "weights" + weights_local = np.asarray(weights, dtype=ctypes.c_double) + weights_dim_1 = ctypes.c_int(weights_local.shape[0]) + weights_dim_2 = ctypes.c_int(weights_local.shape[1]) + + # Setting up "ierr" + ierr_local = np.asarray(ierr, dtype=ctypes.c_int) + # In accordance with how the Fortran code might be normally used, + # and mathematical notation, grabbing the last dimension allows + # ierr to be passed as a column vector instead of a flat vector. + ierr_dim_1 = ctypes.c_int(ierr_local.shape[-1]) + + # Setting up "interp_in" + interp_in_present = ctypes.c_bool(True) + interp_in_dim_1 = ctypes.c_int(0) + interp_in_dim_2 = ctypes.c_int(0) + if (interp_in is None): + interp_in_present = ctypes.c_bool(False) + interp_in = np.zeros(shape=(1,1), dtype=ctypes.c_double, order='F') + elif (type(interp_in) == bool) and (interp_in): + interp_in = np.zeros(shape=(1,1), dtype=ctypes.c_double, order='F') + interp_in_dim_1 = ctypes.c_int(interp_in.shape[0]) + interp_in_dim_2 = ctypes.c_int(interp_in.shape[1]) + elif (not np.asarray(interp_in).flags.f_contiguous): + raise(Exception("The numpy array given as argument 'interp_in' was not f_contiguous.")) + else: + interp_in_dim_1 = ctypes.c_int(interp_in.shape[0]) + interp_in_dim_2 = ctypes.c_int(interp_in.shape[1]) + interp_in_local = np.asarray(interp_in, dtype=ctypes.c_double) + + # Setting up "interp_out" + interp_out_present = ctypes.c_bool(True) + interp_out_dim_1 = ctypes.c_int(0) + interp_out_dim_2 = ctypes.c_int(0) + if (interp_out is None): + interp_out_present = ctypes.c_bool(False) + interp_out = np.zeros(shape=(1,1), dtype=ctypes.c_double, order='F') + elif (type(interp_out) == bool) and (interp_out): + interp_out = np.zeros(shape=(1,1), dtype=ctypes.c_double, order='F') + interp_out_dim_1 = ctypes.c_int(interp_out.shape[0]) + interp_out_dim_2 = ctypes.c_int(interp_out.shape[1]) + elif (not np.asarray(interp_out).flags.f_contiguous): + raise(Exception("The numpy array given as argument 'interp_out' was not f_contiguous.")) + else: + interp_out_dim_1 = ctypes.c_int(interp_out.shape[0]) + interp_out_dim_2 = ctypes.c_int(interp_out.shape[1]) + interp_out_local = np.asarray(interp_out, dtype=ctypes.c_double) + + # Setting up "eps" + eps_present = ctypes.c_bool(True) + if (eps is None): + eps_present = ctypes.c_bool(False) + eps = 1 + eps_local = ctypes.c_double(eps) + + # Setting up "extrap" + extrap_present = ctypes.c_bool(True) + if (extrap is None): + extrap_present = ctypes.c_bool(False) + extrap = 1 + extrap_local = ctypes.c_double(extrap) + + # Setting up "rnorm" + rnorm_present = ctypes.c_bool(True) + rnorm_dim_1 = ctypes.c_int(0) + if (rnorm is None): + rnorm_present = ctypes.c_bool(False) + rnorm = np.zeros(shape=(1), dtype=ctypes.c_double, order='F') + elif (type(rnorm) == bool) and (rnorm): + # In accordance with how the Fortran code might be normally used, + # and mathematical notation, grabbing the last dimension allows + # rnorm to be passed as a column vector instead of a flat vector. + rnorm = np.zeros(shape=(1), dtype=ctypes.c_double, order='F') + rnorm_dim_1 = ctypes.c_int(rnorm.shape[-1]) + elif (not np.asarray(rnorm).flags.f_contiguous): + raise(Exception("The numpy array given as argument 'rnorm' was not f_contiguous.")) + else: + # In accordance with how the Fortran code might be normally used, + # and mathematical notation, grabbing the last dimension allows + # rnorm to be passed as a column vector instead of a flat vector. + rnorm_dim_1 = ctypes.c_int(rnorm.shape[-1]) + rnorm_local = np.asarray(rnorm, dtype=ctypes.c_double) + + # Setting up "ibudget" + ibudget_present = ctypes.c_bool(True) + if (ibudget is None): + ibudget_present = ctypes.c_bool(False) + ibudget = 1 + ibudget_local = ctypes.c_int(ibudget) + + # Setting up "chain" + chain_present = ctypes.c_bool(True) + if (chain is None): + chain_present = ctypes.c_bool(False) + chain = 1 + chain_local = ctypes.c_bool(chain) + + # Setting up "exact" + exact_present = ctypes.c_bool(True) + if (exact is None): + exact_present = ctypes.c_bool(False) + exact = 1 + exact_local = ctypes.c_bool(exact) + + # Call C-accessible Fortran wrapper. + delsparse_clib.c_delaunaysparses(ctypes.byref(d), ctypes.byref(n), ctypes.byref(pts_dim_1), ctypes.byref(pts_dim_2), ctypes.c_void_p(pts_local.ctypes.data), ctypes.byref(m), ctypes.byref(q_dim_1), ctypes.byref(q_dim_2), ctypes.c_void_p(q_local.ctypes.data), ctypes.byref(simps_dim_1), ctypes.byref(simps_dim_2), ctypes.c_void_p(simps_local.ctypes.data), ctypes.byref(weights_dim_1), ctypes.byref(weights_dim_2), ctypes.c_void_p(weights_local.ctypes.data), ctypes.byref(ierr_dim_1), ctypes.c_void_p(ierr_local.ctypes.data), ctypes.byref(interp_in_present), ctypes.byref(interp_in_dim_1), ctypes.byref(interp_in_dim_2), ctypes.c_void_p(interp_in_local.ctypes.data), ctypes.byref(interp_out_present), ctypes.byref(interp_out_dim_1), ctypes.byref(interp_out_dim_2), ctypes.c_void_p(interp_out_local.ctypes.data), ctypes.byref(eps_present), ctypes.byref(eps_local), ctypes.byref(extrap_present), ctypes.byref(extrap_local), ctypes.byref(rnorm_present), ctypes.byref(rnorm_dim_1), ctypes.c_void_p(rnorm_local.ctypes.data), ctypes.byref(ibudget_present), ctypes.byref(ibudget_local), ctypes.byref(chain_present), ctypes.byref(chain_local), ctypes.byref(exact_present), ctypes.byref(exact_local)) + + # Return final results, 'INTENT(OUT)' arguments only. + return np.asarray(pts_local), np.asarray(q_local), np.asarray(simps_local), np.asarray(weights_local), np.asarray(ierr_local), (np.asarray(interp_out_local) if interp_out_present else None), (np.asarray(rnorm_local) if rnorm_present else None) + + +# ---------------------------------------------- +# Wrapper for the Fortran subroutine DELAUNAYSPARSEP + +def delaunaysparsep(d, n, pts, m, q, simps, weights, ierr, interp_in=None, interp_out=None, eps=None, extrap=None, rnorm=None, ibudget=None, chain=None, exact=None, pmode=None): + '''! This is a parallel implementation of an algorithm for efficiently performing +! interpolation in R^D via the Delaunay triangulation. The algorithm is fully +! described and analyzed in +! +! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. +! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate +! interpolation in arbitrary dimension via the Delaunay triangulation. In +! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, +! USA. Article 12, 8 pages. +! +! +! On input: +! +! D is the dimension of the space for PTS and Q. +! +! N is the number of data points in PTS. +! +! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the +! coordinates of a single data point in R^D. +! +! M is the number of interpolation points in Q. +! +! Q(1:D,1:M) is a real valued matrix with M columns, each containing the +! coordinates of a single interpolation point in R^D. +! +! +! On output: +! +! PTS and Q have been rescaled and shifted. All the data points in PTS +! are now contained in the unit hyperball in R^D, and the points in Q +! have been shifted and scaled accordingly in relation to PTS. +! +! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns +! in PTS) for the D+1 vertices of the Delaunay simplex containing each +! interpolation point in Q. +! +! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each +! point in Q as a convex combination of the D+1 corresponding vertices +! in SIMPS. +! +! IERR(1:M) contains integer valued error flags associated with the +! computation of each of the M interpolation points in Q. The error +! codes are: +! +! 00 : Succesful interpolation. +! 01 : Succesful extrapolation (up to the allowed extrapolation distance). +! 02 : This point was outside the allowed extrapolation distance; the +! corresponding entries in SIMPS and WEIGHTS contain zero values. +! +! 10 : The dimension D must be positive. +! 11 : Too few data points to construct a triangulation (i.e., N < D+1). +! 12 : No interpolation points given (i.e., M < 1). +! 13 : The first dimension of PTS does not agree with the dimension D. +! 14 : The second dimension of PTS does not agree with the number of points N. +! 15 : The first dimension of Q does not agree with the dimension D. +! 16 : The second dimension of Q does not agree with the number of +! interpolation points M. +! 17 : The first dimension of the output array SIMPS does not match the number +! of vertices needed for a D-simplex (D+1). +! 18 : The second dimension of the output array SIMPS does not match the +! number of interpolation points M. +! 19 : The first dimension of the output array WEIGHTS does not match the +! number of vertices for a a D-simplex (D+1). +! 20 : The second dimension of the output array WEIGHTS does not match the +! number of interpolation points M. +! 21 : The size of the error array IERR does not match the number of +! interpolation points M. +! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. +! 23 : The first dimension of INTERP_IN does not match the first +! dimension of INTERP_OUT. +! 24 : The second dimension of INTERP_IN does not match the number of +! data points PTS. +! 25 : The second dimension of INTERP_OUT does not match the number of +! interpolation points M. +! 26 : The budget supplied in IBUDGET does not contain a positive +! integer. +! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. +! 28 : The size of the RNORM output array does not match the number of +! interpolation points M. +! +! 30 : Two or more points in the data set PTS are too close together with +! respect to the working precision (EPS), which would result in a +! numerically degenerate simplex. +! 31 : All the data points in PTS lie in some lower dimensional linear +! manifold (up to the working precision), and no valid triangulation +! exists. +! 40 : An error caused DELAUNAYSPARSEP to terminate before this value could +! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may +! contain garbage values. +! +! 50 : A memory allocation error occurred while allocating the work array +! WORK. +! +! 60 : The budget was exceeded before the algorithm converged on this +! value. If the dimension is high, try increasing IBUDGET. This +! error can also be caused by a working precision EPS that is too +! small for the conditioning of the problem. +! +! 61 : A value that was judged appropriate later caused LAPACK to encounter a +! singularity. Try increasing the value of EPS. +! +! 70 : Allocation error for the extrapolation work arrays. +! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection +! of an extrapolation point onto the convex hull. +! 72 : The SLATEC subroutine DWNNLS has reported a usage error. +! +! The errors 72, 80--83 should never occur, and likely indicate a +! compiler bug or hardware failure. +! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. +! 81 : The LAPACK subroutine DGETRF has reported an illegal value. +! 82 : The LAPACK subroutine DGETRS has reported an illegal value. +! 83 : The LAPACK subroutine DORMQR has reported an illegal value. +! +! 90 : The value of PMODE is not valid. +! +! +! Optional arguments: +! +! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of +! the data points in PTS on input. The first dimension of INTERP_IN is +! inferred to be the dimension of these response vectors, and the +! second dimension must match N. If present, the response values will +! be computed for each interpolation point in Q, and stored in INTERP_OUT, +! which therefore must also be present. If both INTERP_IN and INTERP_OUT +! are omitted, only the containing simplices and convex combination +! weights are returned. +! +! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each +! interpolation point in Q on output. The first dimension of INTERP_OU +! must match the first dimension of INTERP_IN, and the second dimension +! must match M. If present, the response values at each interpolation +! point are computed as a convex combination of the response values +! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing +! that interpolation point. Therefore, if INTERP_OUT is present, then +! INTERP_IN must also be present. If both are omitted, only the +! simplices and convex combination weights are returned. +! +! EPS contains the real working precision for the problem on input. By +! default, EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff +! for the machine. In general, any values that differ by less than EPS +! are judged as equal, and any weights that are greater than -EPS are +! judged as nonnegative. EPS cannot take a value less than the default +! value of \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, +! the default value will be used instead automatically. +! +! EXTRAP contains the real maximum extrapolation distance (relative to the +! diameter of PTS) on input. Interpolation at a point outside the convex +! hull of PTS is done by projecting that point onto the convex hull, and +! then doing normal Delaunay interpolation at that projection. +! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) +! units outside the convex hull of PTS will not be done and an error code +! of 2 will be returned. Note that computing the projection can be +! expensive. Setting EXTRAP=0 will cause all extrapolation points to be +! ignored without ever computing a projection. By default, EXTRAP=0.1 +! (extrapolate by up to 10% of the diameter of PTS). +! +! RNORM(1:M) contains the real unscaled projection (2-norm) distances from +! any projection computations on output. If not present, these distances +! are still computed for each extrapolation point, but are never returned. +! +! IBUDGET on input contains the integer budget for performing flips while +! iterating toward the simplex containing each interpolation point in Q. +! This prevents DELAUNAYSPARSEP from falling into an infinite loop when +! an inappropriate value of EPS is given with respect to the problem +! conditioning. By default, IBUDGET=50000. However, for extremely +! high-dimensional problems and pathological inputs, the default value +! may be insufficient. +! +! CHAIN is a logical input argument that determines whether a new first +! simplex should be constructed for each interpolation point +! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." +! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not +! recommended, unless the size of the triangulation is relatively small +! or the interpolation points are known to be tightly clustered. +! +! EXACT is a logical input argument that determines whether the exact +! diameter should be computed and whether a check for duplicate data +! points should be performed in advance. When EXACT=.FALSE., the +! diameter of PTS is approximated by twice the distance from the +! barycenter of PTS to the farthest point in PTS, and no check is +! done to find the closest pair of points, which could result in hard +! to find bugs later on. When EXACT=.TRUE., the exact diameter is +! computed and an error is returned whenever PTS contains duplicate +! values up to the precision EPS. By default EXACT=.TRUE., but setting +! EXACT=.FALSE. could result in significant speedup when N is large. +! It is strongly recommended that most users leave EXACT=.TRUE., as +! setting EXACT=.FALSE. could result in input errors that are difficult +! to identify. Also, the diameter approximation could be wrong by up to +! a factor of two. +! +! PMODE is an integer specifying the level of parallelism to be exploited. +! If PMODE = 1, then parallelism is exploited at the level of the loop +! over all interpolation points (Level 1 parallelism). +! If PMODE = 2, then parallelism is exploited at the level of the loops +! over data points when constructing/flipping simplices (Level 2 +! parallelism). +! If PMODE = 3, then parallelism is exploited at both levels. Note: this +! implies that the total number of threads active at any time could be up +! to OMP_NUM_THREADS^2. +! By default, PMODE is set to 1 if there is more than 1 interpolation +! point and 2 otherwise. +! +! +! Subroutines and functions directly referenced from BLAS are +! DDOT, DGEMV, DNRM2, DTRSM, +! and from LAPACK are +! DGEQP3, DGETRF, DGETRS, DORMQR. +! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its +! SLATEC dependencies have been slightly edited to comply with the Fortran +! 2008 standard, with all print statements and references to stderr being +! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 +! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS +! Algorithm 777) is used for the real data type. The REAL_PRECISION module, +! DELAUNAYSPARSEP, and DWNNLS and its dependencies comply with the Fortran +! 2008 standard. +! +! Primary Author: Tyler H. Chang +! Last Update: March, 2020 +!''' + + # Setting up "d" + d = ctypes.c_int(d) + + # Setting up "n" + n = ctypes.c_int(n) + + # Setting up "m" + m = ctypes.c_int(m) + + # Setting up "pts" + pts_local = np.asarray(pts, dtype=ctypes.c_double) + pts_dim_1 = ctypes.c_int(pts_local.shape[0]) + pts_dim_2 = ctypes.c_int(pts_local.shape[1]) + + # Setting up "q" + q_local = np.asarray(q, dtype=ctypes.c_double) + q_dim_1 = ctypes.c_int(q_local.shape[0]) + q_dim_2 = ctypes.c_int(q_local.shape[1]) + + # Setting up "simps" + simps_local = np.asarray(simps, dtype=ctypes.c_int) + simps_dim_1 = ctypes.c_int(simps_local.shape[0]) + simps_dim_2 = ctypes.c_int(simps_local.shape[1]) + + # Setting up "weights" + weights_local = np.asarray(weights, dtype=ctypes.c_double) + weights_dim_1 = ctypes.c_int(weights_local.shape[0]) + weights_dim_2 = ctypes.c_int(weights_local.shape[1]) + + # Setting up "ierr" + ierr_local = np.asarray(ierr, dtype=ctypes.c_int) + # In accordance with how the Fortran code might be normally used, + # and mathematical notation, grabbing the last dimension allows + # ierr to be passed as a column vector instead of a flat vector. + ierr_dim_1 = ctypes.c_int(ierr_local.shape[-1]) + + # Setting up "interp_in" + interp_in_present = ctypes.c_bool(True) + interp_in_dim_1 = ctypes.c_int(0) + interp_in_dim_2 = ctypes.c_int(0) + if (interp_in is None): + interp_in_present = ctypes.c_bool(False) + interp_in = np.zeros(shape=(1,1), dtype=ctypes.c_double, order='F') + elif (type(interp_in) == bool) and (interp_in): + interp_in = np.zeros(shape=(1,1), dtype=ctypes.c_double, order='F') + interp_in_dim_1 = ctypes.c_int(interp_in.shape[0]) + interp_in_dim_2 = ctypes.c_int(interp_in.shape[1]) + elif (not np.asarray(interp_in).flags.f_contiguous): + raise(Exception("The numpy array given as argument 'interp_in' was not f_contiguous.")) + else: + interp_in_dim_1 = ctypes.c_int(interp_in.shape[0]) + interp_in_dim_2 = ctypes.c_int(interp_in.shape[1]) + interp_in_local = np.asarray(interp_in, dtype=ctypes.c_double) + + # Setting up "interp_out" + interp_out_present = ctypes.c_bool(True) + interp_out_dim_1 = ctypes.c_int(0) + interp_out_dim_2 = ctypes.c_int(0) + if (interp_out is None): + interp_out_present = ctypes.c_bool(False) + interp_out = np.zeros(shape=(1,1), dtype=ctypes.c_double, order='F') + elif (type(interp_out) == bool) and (interp_out): + interp_out = np.zeros(shape=(1,1), dtype=ctypes.c_double, order='F') + interp_out_dim_1 = ctypes.c_int(interp_out.shape[0]) + interp_out_dim_2 = ctypes.c_int(interp_out.shape[1]) + elif (not np.asarray(interp_out).flags.f_contiguous): + raise(Exception("The numpy array given as argument 'interp_out' was not f_contiguous.")) + else: + interp_out_dim_1 = ctypes.c_int(interp_out.shape[0]) + interp_out_dim_2 = ctypes.c_int(interp_out.shape[1]) + interp_out_local = np.asarray(interp_out, dtype=ctypes.c_double) + + # Setting up "eps" + eps_present = ctypes.c_bool(True) + if (eps is None): + eps_present = ctypes.c_bool(False) + eps = 1 + eps_local = ctypes.c_double(eps) + + # Setting up "extrap" + extrap_present = ctypes.c_bool(True) + if (extrap is None): + extrap_present = ctypes.c_bool(False) + extrap = 1 + extrap_local = ctypes.c_double(extrap) + + # Setting up "rnorm" + rnorm_present = ctypes.c_bool(True) + rnorm_dim_1 = ctypes.c_int(0) + if (rnorm is None): + rnorm_present = ctypes.c_bool(False) + rnorm = np.zeros(shape=(1), dtype=ctypes.c_double, order='F') + elif (type(rnorm) == bool) and (rnorm): + rnorm = np.zeros(shape=(1), dtype=ctypes.c_double, order='F') + # In accordance with how the Fortran code might be normally used, + # and mathematical notation, grabbing the last dimension allows + # rnorm to be passed as a column vector instead of a flat vector. + rnorm_dim_1 = rnorm.shape[-1] + elif (not np.asarray(rnorm).flags.f_contiguous): + raise(Exception("The numpy array given as argument 'rnorm' was not f_contiguous.")) + else: + # In accordance with how the Fortran code might be normally used, + # and mathematical notation, grabbing the last dimension allows + # rnorm to be passed as a column vector instead of a flat vector. + rnorm_dim_1 = ctypes.c_int(rnorm.shape[-1]) + rnorm_local = np.asarray(rnorm, dtype=ctypes.c_double) + + # Setting up "ibudget" + ibudget_present = ctypes.c_bool(True) + if (ibudget is None): + ibudget_present = ctypes.c_bool(False) + ibudget = 1 + ibudget_local = ctypes.c_int(ibudget) + + # Setting up "chain" + chain_present = ctypes.c_bool(True) + if (chain is None): + chain_present = ctypes.c_bool(False) + chain = 1 + chain_local = ctypes.c_bool(chain) + + # Setting up "exact" + exact_present = ctypes.c_bool(True) + if (exact is None): + exact_present = ctypes.c_bool(False) + exact = 1 + exact_local = ctypes.c_bool(exact) + + # Setting up "pmode" + pmode_present = ctypes.c_bool(True) + if (pmode is None): + pmode_present = ctypes.c_bool(False) + pmode = 1 + pmode_local = ctypes.c_int(pmode) + + # Call C-accessible Fortran wrapper. + delsparse_clib.c_delaunaysparsep(ctypes.byref(d), ctypes.byref(n), ctypes.byref(pts_dim_1), ctypes.byref(pts_dim_2), ctypes.c_void_p(pts_local.ctypes.data), ctypes.byref(m), ctypes.byref(q_dim_1), ctypes.byref(q_dim_2), ctypes.c_void_p(q_local.ctypes.data), ctypes.byref(simps_dim_1), ctypes.byref(simps_dim_2), ctypes.c_void_p(simps_local.ctypes.data), ctypes.byref(weights_dim_1), ctypes.byref(weights_dim_2), ctypes.c_void_p(weights_local.ctypes.data), ctypes.byref(ierr_dim_1), ctypes.c_void_p(ierr_local.ctypes.data), ctypes.byref(interp_in_present), ctypes.byref(interp_in_dim_1), ctypes.byref(interp_in_dim_2), ctypes.c_void_p(interp_in_local.ctypes.data), ctypes.byref(interp_out_present), ctypes.byref(interp_out_dim_1), ctypes.byref(interp_out_dim_2), ctypes.c_void_p(interp_out_local.ctypes.data), ctypes.byref(eps_present), ctypes.byref(eps_local), ctypes.byref(extrap_present), ctypes.byref(extrap_local), ctypes.byref(rnorm_present), ctypes.byref(rnorm_dim_1), ctypes.c_void_p(rnorm_local.ctypes.data), ctypes.byref(ibudget_present), ctypes.byref(ibudget_local), ctypes.byref(chain_present), ctypes.byref(chain_local), ctypes.byref(exact_present), ctypes.byref(exact_local), ctypes.byref(pmode_present), ctypes.byref(pmode_local)) + + # Return final results, 'INTENT(OUT)' arguments only. + return np.asarray(pts_local), np.asarray(q_local), np.asarray(simps_local), np.asarray(weights_local), np.asarray(ierr_local), (np.asarray(interp_out_local) if interp_out_present else None), (np.asarray(rnorm_local) if rnorm_present else None) + diff --git a/python/delsparse_src/blas.f b/python/delsparse_src/blas.f new file mode 100755 index 0000000..df991ff --- /dev/null +++ b/python/delsparse_src/blas.f @@ -0,0 +1,2206 @@ + +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* ====================================== + + DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* Purpose: +* ============= +* +* DASUM takes the sum of the absolute values. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 3/93 to return if incx .le. 0. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,M,MP1,NINCX +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS,MOD +* .. + DASUM = 0.0D0 + DTEMP = 0.0D0 + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,6) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DTEMP + DABS(DX(I)) + END DO + IF (N.LT.6) THEN + DASUM = DTEMP + RETURN + END IF + END IF + MP1 = M + 1 + DO I = MP1,N,6 + DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) + + $ DABS(DX(I+2)) + DABS(DX(I+3)) + + $ DABS(DX(I+4)) + DABS(DX(I+5)) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + DTEMP = DTEMP + DABS(DX(I)) + END DO + END IF + DASUM = DTEMP + RETURN + END + + SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* Purpose: +* ============= +* +* DAXPY constant times a vector plus a vector. +* uses unrolled loops for increments equal to one. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DA is DOUBLE PRECISION. On entry, DA specifies the scalar alpha. +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +* +* INCY is INTEGER storage spacing between elements of DY +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (DA.EQ.0.0D0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,4) + IF (M.NE.0) THEN + DO I = 1,M + DY(I) = DY(I) + DA*DX(I) + END DO + END IF + IF (N.LT.4) RETURN + MP1 = M + 1 + DO I = MP1,N,4 + DY(I) = DY(I) + DA*DX(I) + DY(I+1) = DY(I+1) + DA*DX(I+1) + DY(I+2) = DY(I+2) + DA*DX(I+2) + DY(I+3) = DY(I+3) + DA*DX(I+3) + END DO + ELSE +* +* code for unequal increments or equal increments +* 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 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN + END + + SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* Purpose: +* ============= +* +* DCOPY copies a vector, x, to a vector, y. +* uses unrolled loops for increments equal to 1. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +* +* INCY is INTEGER storage spacing between elements of DY +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,7) + IF (M.NE.0) THEN + DO I = 1,M + DY(I) = DX(I) + END DO + IF (N.LT.7) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,7 + DY(I) = DX(I) + DY(I+1) = DX(I+1) + DY(I+2) = DX(I+2) + DY(I+3) = DX(I+3) + DY(I+4) = DX(I+4) + DY(I+5) = DX(I+5) + DY(I+6) = DX(I+6) + END DO + ELSE +* +* code for unequal increments or equal increments +* 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 I = 1,N + DY(IY) = DX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN + END + + DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* Purpose: +* ============= +* +* DDOT forms the dot product of two vectors. +* uses unrolled loops for increments equal to one. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +* +* INCY is INTEGER storage spacing between elements of DY +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + DDOT = 0.0D0 + DTEMP = 0.0D0 + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DTEMP + DX(I)*DY(I) + END DO + IF (N.LT.5) THEN + DDOT=DTEMP + RETURN + END IF + END IF + MP1 = M + 1 + DO I = MP1,N,5 + DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) + + $ DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) + END DO + ELSE +* +* code for unequal increments or equal increments +* 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 I = 1,N + DTEMP = DTEMP + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + DDOT = DTEMP + RETURN + END + + SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of +* Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB + LOGICAL NOTA,NOTB +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are +* not +* transposed and set NROWA, NCOLA and NROWB as the number of +* rows +* and columns of A and the number of rows of B +* respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + IF (NOTA) THEN + NROWA = M + NCOLA = K + ELSE + NROWA = K + NCOLA = M + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And if alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF (NOTA) THEN +* +* Form C := alpha*A*B**T + beta*C +* + DO 170 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 130 I = 1,M + C(I,J) = ZERO + 130 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 140 I = 1,M + C(I,J) = BETA*C(I,J) + 140 CONTINUE + END IF + DO 160 L = 1,K + TEMP = ALPHA*B(J,L) + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 200 J = 1,N + DO 190 I = 1,M + TEMP = ZERO + DO 180 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 180 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMM . +* + END + + SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER INCX,INCY,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* Purpose: +* ============= +* +* DGEMV performs one of the matrix-vector operations +* +* y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, +* +* where alpha and beta are scalars, x and y are vectors and A is an +* m by n matrix. +* +* Arguments: +* ========== +* +* TRANS is CHARACTER*1 +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +* +* TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. +* +* TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. +* M is INTEGER +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* +* N is INTEGER +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* +* ALPHA is DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* +* A is DOUBLE PRECISION array, dimension ( LDA, N ) +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* +* LDA is INTEGER +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* +* X is DOUBLE PRECISION array, dimension at least +* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +* Before entry, the incremented array X must contain the +* vector x. +* +* INCX is INTEGER +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* +* BETA is DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* +* Y is DOUBLE PRECISION array, dimension at least +* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY is INTEGER +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* +* Further Details: +* ===================== +* +* Level 2 Blas routine. +* The vector and matrix arguments are not referenced when N = 0, or M = 0 +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 1 + ELSE IF (M.LT.0) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + ELSE IF (INCY.EQ.0) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGEMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF (LSAME(TRANS,'N')) THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (LENX-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (LENY-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,LENY + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,LENY + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,LENY + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,LENY + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(TRANS,'N')) THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF (INCY.EQ.1) THEN + DO 60 J = 1,N + TEMP = ALPHA*X(JX) + DO 50 I = 1,M + Y(I) = Y(I) + TEMP*A(I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + DO 70 I = 1,M + Y(IY) = Y(IY) + TEMP*A(I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = ZERO + DO 90 I = 1,M + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120 J = 1,N + TEMP = ZERO + IX = KX + DO 110 I = 1,M + TEMP = TEMP + A(I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMV . +* + END + + SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of +* Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER(ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JY,KX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (M.LT.0) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGER ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (INCY.GT.0) THEN + JY = 1 + ELSE + JY = 1 - (N-1)*INCY + END IF + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + DO 10 I = 1,M + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + JY = JY + INCY + 20 CONTINUE + ELSE + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (M-1)*INCX + END IF + DO 40 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + IX = KX + DO 30 I = 1,M + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JY = JY + INCY + 40 CONTINUE + END IF +* + RETURN +* +* End of DGER . +* + END + + DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION X(*) +* .. +* +* Purpose: +* ============= +* +* DNRM2 returns the euclidean norm of a vector via the function +* name, so that +* +* DNRM2 := sqrt( x'*x ) +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* Further Details: +* ===================== +* +* -- This version written on 25-October-1982. +* Modified on 14-October-1993 to inline the call to DLASSQ. +* Sven Hammarling, Nag Ltd. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ + INTEGER IX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS,SQRT +* .. + IF (N.LT.1 .OR. INCX.LT.1) THEN + NORM = ZERO + ELSE IF (N.EQ.1) THEN + NORM = ABS(X(1)) + ELSE + SCALE = ZERO + SSQ = ONE +* The following loop is equivalent to this call to the LAPACK +* auxiliary routine: +* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) +* + DO 10 IX = 1,1 + (N-1)*INCX,INCX + IF (X(IX).NE.ZERO) THEN + ABSXI = ABS(X(IX)) + IF (SCALE.LT.ABSXI) THEN + SSQ = ONE + SSQ* (SCALE/ABSXI)**2 + SCALE = ABSXI + ELSE + SSQ = SSQ + (ABSXI/SCALE)**2 + END IF + END IF + 10 CONTINUE + NORM = SCALE*SQRT(SSQ) + END IF +* + DNRM2 = NORM + RETURN +* +* End of DNRM2. +* + END + + SUBROUTINE DSCAL(N,DA,DX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* Purpose: +* ============= +* +* DSCAL scales a vector by a constant. +* uses unrolled loops for increment equal to 1. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DA is DOUBLE PRECISION On entry, DA specifies the scalar alpha. +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 3/93 to return if incx .le. 0. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,M,MP1,NINCX +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + DX(I) = DA*DX(I) + END DO + IF (N.LT.5) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I+1) = DA*DX(I+1) + DX(I+2) = DA*DX(I+2) + DX(I+3) = DA*DX(I+3) + DX(I+4) = DA*DX(I+4) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + DX(I) = DA*DX(I) + END DO + END IF + RETURN + END + + SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* Purpose: +* ============= +* +* DSWAP interchanges two vectors. +* uses unrolled loops for increments equal to 1. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +* +* INCY is INTEGER storage spacing between elements of DY +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,3) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + END DO + IF (N.LT.3) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,3 + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + DTEMP = DX(I+1) + DX(I+1) = DY(I+1) + DY(I+1) = DTEMP + DTEMP = DX(I+2) + DX(I+2) = DY(I+2) + DY(I+2) = DTEMP + END DO + ELSE +* +* code for unequal increments or equal increments 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 I = 1,N + DTEMP = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN + END + + SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of +* Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOUNIT,UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTRMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*A*B. +* + IF (UPPER) THEN + DO 50 J = 1,N + DO 40 K = 1,M + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + DO 30 I = 1,K - 1 + B(I,J) = B(I,J) + TEMP*A(I,K) + 30 CONTINUE + IF (NOUNIT) TEMP = TEMP*A(K,K) + B(K,J) = TEMP + END IF + 40 CONTINUE + 50 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + B(K,J) = TEMP + IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) + DO 60 I = K + 1,M + B(I,J) = B(I,J) + TEMP*A(I,K) + 60 CONTINUE + END IF + 70 CONTINUE + 80 CONTINUE + END IF + ELSE +* +* Form B := alpha*A**T*B. +* + IF (UPPER) THEN + DO 110 J = 1,N + DO 100 I = M,1,-1 + TEMP = B(I,J) + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 90 K = 1,I - 1 + TEMP = TEMP + A(K,I)*B(K,J) + 90 CONTINUE + B(I,J) = ALPHA*TEMP + 100 CONTINUE + 110 CONTINUE + ELSE + DO 140 J = 1,N + DO 130 I = 1,M + TEMP = B(I,J) + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 120 K = I + 1,M + TEMP = TEMP + A(K,I)*B(K,J) + 120 CONTINUE + B(I,J) = ALPHA*TEMP + 130 CONTINUE + 140 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*A. +* + IF (UPPER) THEN + DO 180 J = N,1,-1 + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = 1,M + B(I,J) = TEMP*B(I,J) + 150 CONTINUE + DO 170 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 160 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + ELSE + DO 220 J = 1,N + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 190 I = 1,M + B(I,J) = TEMP*B(I,J) + 190 CONTINUE + DO 210 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 200 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 200 CONTINUE + END IF + 210 CONTINUE + 220 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*A**T. +* + IF (UPPER) THEN + DO 260 K = 1,N + DO 240 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + TEMP = ALPHA*A(J,K) + DO 230 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 230 CONTINUE + END IF + 240 CONTINUE + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(K,K) + IF (TEMP.NE.ONE) THEN + DO 250 I = 1,M + B(I,K) = TEMP*B(I,K) + 250 CONTINUE + END IF + 260 CONTINUE + ELSE + DO 300 K = N,1,-1 + DO 280 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + TEMP = ALPHA*A(J,K) + DO 270 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 270 CONTINUE + END IF + 280 CONTINUE + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(K,K) + IF (TEMP.NE.ONE) THEN + DO 290 I = 1,M + B(I,K) = TEMP*B(I,K) + 290 CONTINUE + END IF + 300 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRMM . +* + END + + SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of +* Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER(ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTRMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := A*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*A(I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 I = 1,J - 1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*A(I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 70 I = N,J + 1,-1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 100 J = N,1,-1 + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 90 I = J - 1,1,-1 + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + X(J) = TEMP + 100 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 120 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 110 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + A(I,J)*X(IX) + 110 CONTINUE + X(JX) = TEMP + JX = JX - INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = 1,N + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 130 I = J + 1,N + TEMP = TEMP + A(I,J)*X(I) + 130 CONTINUE + X(J) = TEMP + 140 CONTINUE + ELSE + JX = KX + DO 160 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + A(I,J)*X(IX) + 150 CONTINUE + X(JX) = TEMP + JX = JX + INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRMV . +* + END + + SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*) +* .. +* +* Purpose: +* ============= +* +* DTRSM solves one of the matrix equations +* +* op( A )*X = alpha*B, or X*op( A ) = alpha*B, +* +* where alpha is a scalar, X and B are m by n matrices, A is a unit, or +* non-unit, upper or lower triangular matrix and op( A ) is one of +* +* op( A ) = A or op( A ) = A**T. +* +* The matrix X is overwritten on B. +* +* Arguments: +* ========== +* +* SIDE is CHARACTER*1 +* On entry, SIDE specifies whether op( A ) appears on the left +* or right of X as follows: +* +* SIDE = 'L' or 'l' op( A )*X = alpha*B. +* +* SIDE = 'R' or 'r' X*op( A ) = alpha*B. +* +* UPLO is CHARACTER*1 +* On entry, UPLO specifies whether the matrix A is an upper or +* lower triangular matrix as follows: +* +* UPLO = 'U' or 'u' A is an upper triangular matrix. +* +* UPLO = 'L' or 'l' A is a lower triangular matrix. +* +* TRANSA is CHARACTER*1 +* On entry, TRANSA specifies the form of op( A ) to be used in +* the matrix multiplication as follows: +* +* TRANSA = 'N' or 'n' op( A ) = A. +* +* TRANSA = 'T' or 't' op( A ) = A**T. +* +* TRANSA = 'C' or 'c' op( A ) = A**T. +* +* DIAG is CHARACTER*1 +* On entry, DIAG specifies whether or not A is unit triangular +* as follows: +* +* DIAG = 'U' or 'u' A is assumed to be unit triangular. +* +* DIAG = 'N' or 'n' A is not assumed to be unit +* triangular. +* +* M is INTEGER +* On entry, M specifies the number of rows of B. M must be at +* least zero. +* +* N is INTEGER +* On entry, N specifies the number of columns of B. N must be +* at least zero. +* +* ALPHA is DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. When alpha is +* zero then A is not referenced and B need not be set before +* entry. +* +* A is DOUBLE PRECISION array, dimension ( LDA, k ), +* where k is m when SIDE = 'L' or 'l' +* and k is n when SIDE = 'R' or 'r'. +* Before entry with UPLO = 'U' or 'u', the leading k by k +* upper triangular part of the array A must contain the upper +* triangular matrix and the strictly lower triangular part of +* A is not referenced. +* Before entry with UPLO = 'L' or 'l', the leading k by k +* lower triangular part of the array A must contain the lower +* triangular matrix and the strictly upper triangular part of +* A is not referenced. +* Note that when DIAG = 'U' or 'u', the diagonal elements of +* A are not referenced either, but are assumed to be unity. +* +* LDA is INTEGER +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When SIDE = 'L' or 'l' then +* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +* then LDA must be at least max( 1, n ). +* +* B is DOUBLE PRECISION array, dimension ( LDB, N ) +* Before entry, the leading m by n part of the array B must +* contain the right-hand side matrix B, and on exit is +* overwritten by the solution matrix X. +* +* LDB is INTEGER +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. LDB must be at least +* max( 1, m ). +* +* Further Details: +* ===================== +* +* Level 3 Blas routine. +* +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOUNIT,UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTRSM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*inv( A )*B. +* + IF (UPPER) THEN + DO 60 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 30 I = 1,M + B(I,J) = ALPHA*B(I,J) + 30 CONTINUE + END IF + DO 50 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 40 I = 1,K - 1 + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 40 CONTINUE + END IF + 50 CONTINUE + 60 CONTINUE + ELSE + DO 100 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 70 I = 1,M + B(I,J) = ALPHA*B(I,J) + 70 CONTINUE + END IF + DO 90 K = 1,M + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 80 I = K + 1,M + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 80 CONTINUE + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form B := alpha*inv( A**T )*B. +* + IF (UPPER) THEN + DO 130 J = 1,N + DO 120 I = 1,M + TEMP = ALPHA*B(I,J) + DO 110 K = 1,I - 1 + TEMP = TEMP - A(K,I)*B(K,J) + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + B(I,J) = TEMP + 120 CONTINUE + 130 CONTINUE + ELSE + DO 160 J = 1,N + DO 150 I = M,1,-1 + TEMP = ALPHA*B(I,J) + DO 140 K = I + 1,M + TEMP = TEMP - A(K,I)*B(K,J) + 140 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + B(I,J) = TEMP + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*inv( A ). +* + IF (UPPER) THEN + DO 210 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 170 I = 1,M + B(I,J) = ALPHA*B(I,J) + 170 CONTINUE + END IF + DO 190 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + DO 180 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 180 CONTINUE + END IF + 190 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 200 I = 1,M + B(I,J) = TEMP*B(I,J) + 200 CONTINUE + END IF + 210 CONTINUE + ELSE + DO 260 J = N,1,-1 + IF (ALPHA.NE.ONE) THEN + DO 220 I = 1,M + B(I,J) = ALPHA*B(I,J) + 220 CONTINUE + END IF + DO 240 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + DO 230 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 230 CONTINUE + END IF + 240 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 250 I = 1,M + B(I,J) = TEMP*B(I,J) + 250 CONTINUE + END IF + 260 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*inv( A**T ). +* + IF (UPPER) THEN + DO 310 K = N,1,-1 + IF (NOUNIT) THEN + TEMP = ONE/A(K,K) + DO 270 I = 1,M + B(I,K) = TEMP*B(I,K) + 270 CONTINUE + END IF + DO 290 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + TEMP = A(J,K) + DO 280 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 280 CONTINUE + END IF + 290 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 300 I = 1,M + B(I,K) = ALPHA*B(I,K) + 300 CONTINUE + END IF + 310 CONTINUE + ELSE + DO 360 K = 1,N + IF (NOUNIT) THEN + TEMP = ONE/A(K,K) + DO 320 I = 1,M + B(I,K) = TEMP*B(I,K) + 320 CONTINUE + END IF + DO 340 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + TEMP = A(J,K) + DO 330 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 330 CONTINUE + END IF + 340 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 350 I = 1,M + B(I,K) = ALPHA*B(I,K) + 350 CONTINUE + END IF + 360 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRSM . +* + END + + INTEGER FUNCTION IDAMAX(N,DX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* Purpose: +* ============= +* +* IDAMAX finds the index of the first element having maximum absolute value. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of SX +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 3/93 to return if incx .le. 0. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DMAX + INTEGER I,IX +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS +* .. + IDAMAX = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + IDAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DMAX = DABS(DX(1)) + DO I = 2,N + IF (DABS(DX(I)).GT.DMAX) THEN + IDAMAX = I + DMAX = DABS(DX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + DMAX = DABS(DX(1)) + IX = IX + INCX + DO I = 2,N + IF (DABS(DX(IX)).GT.DMAX) THEN + IDAMAX = I + DMAX = DABS(DX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN + END + + LOGICAL FUNCTION LSAME(CA,CB) +* +* -- Reference BLAS level1 routine (version 3.1) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER CA,CB +* .. +* +* Purpose: +* ============= +* +* LSAME returns .TRUE. if CA is the same letter as CB regardless of +* case. +* +* Arguments: +* ========== +* +* CA is CHARACTER*1 +* CB is CHARACTER*1 +* CA and CB specify the single characters to be compared. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA,INTB,ZCODE +* .. +* +* Test if the characters are equal +* + LSAME = CA .EQ. CB + IF (LSAME) RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + ZCODE = ICHAR('Z') +* +* Use 'Z' rather than 'A' so that ASCII can be detected on Prime +* machines, on which ICHAR returns a value with bit 8 set. +* ICHAR('A') on Prime machines returns 193 which is the same as +* ICHAR('A') on an EBCDIC machine. +* + INTA = ICHAR(CA) + INTB = ICHAR(CB) +* + IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 + IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 +* + ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.129 .AND. INTA.LE.137 .OR. + + INTA.GE.145 .AND. INTA.LE.153 .OR. + + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 + IF (INTB.GE.129 .AND. INTB.LE.137 .OR. + + INTB.GE.145 .AND. INTB.LE.153 .OR. + + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 +* + ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 + IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 + END IF + LSAME = INTA .EQ. INTB +* +* RETURN +* +* End of LSAME +* + END + + SUBROUTINE XERBLA( SRNAME, INFO ) +* +* -- Reference BLAS level1 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER*(*) SRNAME + INTEGER INFO +* .. +* +* Purpose: +* ============= +* +* XERBLA is an error handler for the LAPACK routines. +* It is called by an LAPACK routine if an input parameter has an +* invalid value. A message is printed and execution stops. +* +* Installers may consider modifying the STOP statement in order to +* call system-specific exception-handling facilities. +* +* Arguments: +* ========== +* +* SRNAME is CHARACTER*(*) +* The name of the routine which called XERBLA. +* +* INFO is INTEGER +* The position of the invalid parameter in the parameter list +* of the calling routine. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM +* .. +* .. Executable Statements .. +* + WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO +* + STOP +* + 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END + diff --git a/python/delsparse_src/delsparse.f90 b/python/delsparse_src/delsparse.f90 new file mode 100644 index 0000000..3ba0a87 --- /dev/null +++ b/python/delsparse_src/delsparse.f90 @@ -0,0 +1,2774 @@ +MODULE DELSPARSE_MOD +! This module contains the REAL_PRECISION R8 data type for 64-bit arithmetic +! and interface blocks for the DELAUNAYSPARSES and DELAUNAYSPARSEP +! subroutines for computing the Delaunay simplices containing interpolation +! points Q in R^D given data points PTS. +USE REAL_PRECISION +PUBLIC + +INTERFACE + ! Interface for serial subroutine DELAUNAYSPARSES. + SUBROUTINE DELAUNAYSPARSES( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, & + IBUDGET, CHAIN, EXACT ) + USE REAL_PRECISION, ONLY : R8 + INTEGER, INTENT(IN) :: D, N + REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) + INTEGER, INTENT(IN) :: M + REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) + INTEGER, INTENT(OUT) :: SIMPS(:,:) + REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) + INTEGER, INTENT(OUT) :: IERR(:) + REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) + REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) + INTEGER, INTENT(IN), OPTIONAL :: IBUDGET + LOGICAL, INTENT(IN), OPTIONAL :: CHAIN + LOGICAL, INTENT(IN), OPTIONAL :: EXACT + END SUBROUTINE DELAUNAYSPARSES + + ! Interface for parallel subroutine DELAUNAYSPARSEP. + SUBROUTINE DELAUNAYSPARSEP( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, & + IBUDGET, CHAIN, EXACT, PMODE ) + USE REAL_PRECISION, ONLY : R8 + INTEGER, INTENT(IN) :: D, N + REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) + INTEGER, INTENT(IN) :: M + REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) + INTEGER, INTENT(OUT) :: SIMPS(:,:) + REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) + INTEGER, INTENT(OUT) :: IERR(:) + REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) + REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP + REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) + INTEGER, INTENT(IN), OPTIONAL :: IBUDGET + LOGICAL, INTENT(IN), OPTIONAL :: CHAIN + LOGICAL, INTENT(IN), OPTIONAL :: EXACT + INTEGER, INTENT(IN), OPTIONAL :: PMODE + END SUBROUTINE DELAUNAYSPARSEP + + ! Interface for SLATEC subroutine DWNNLS. + SUBROUTINE DWNNLS( W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, & + MODE, IWORK, WORK ) + USE REAL_PRECISION, ONLY : R8 + INTEGER :: IWORK(*), L, MA, MDW, ME, MODE, N + REAL(KIND=R8) :: PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) + END SUBROUTINE DWNNLS + +END INTERFACE + +END MODULE DELSPARSE_MOD + +SUBROUTINE DELAUNAYSPARSES( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EXACT ) +! This is a serial implementation of an algorithm for efficiently performing +! interpolation in R^D via the Delaunay triangulation. The algorithm is fully +! described and analyzed in +! +! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. +! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate +! interpolation in arbitrary dimension via the Delaunay triangulation. In +! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, +! USA. Article 12, 8 pages. +! +! +! On input: +! +! D is the dimension of the space for PTS and Q. +! +! N is the number of data points in PTS. +! +! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the +! coordinates of a single data point in R^D. +! +! M is the number of interpolation points in Q. +! +! Q(1:D,1:M) is a real valued matrix with M columns, each containing the +! coordinates of a single interpolation point in R^D. +! +! +! On output: +! +! PTS and Q have been rescaled and shifted. All the data points in PTS +! are now contained in the unit hyperball in R^D, and the points in Q +! have been shifted and scaled accordingly in relation to PTS. +! +! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns +! in PTS) for the D+1 vertices of the Delaunay simplex containing each +! interpolation point in Q. +! +! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each +! point in Q as a convex combination of the D+1 corresponding vertices +! in SIMPS. +! +! IERR(1:M) contains integer valued error flags associated with the +! computation of each of the M interpolation points in Q. The error +! codes are: +! +! 00 : Succesful interpolation. +! 01 : Succesful extrapolation (up to the allowed extrapolation distance). +! 02 : This point was outside the allowed extrapolation distance; the +! corresponding entries in SIMPS and WEIGHTS contain zero values. +! +! 10 : The dimension D must be positive. +! 11 : Too few data points to construct a triangulation (i.e., N < D+1). +! 12 : No interpolation points given (i.e., M < 1). +! 13 : The first dimension of PTS does not agree with the dimension D. +! 14 : The second dimension of PTS does not agree with the number of points N. +! 15 : The first dimension of Q does not agree with the dimension D. +! 16 : The second dimension of Q does not agree with the number of +! interpolation points M. +! 17 : The first dimension of the output array SIMPS does not match the number +! of vertices needed for a D-simplex (D+1). +! 18 : The second dimension of the output array SIMPS does not match the +! number of interpolation points M. +! 19 : The first dimension of the output array WEIGHTS does not match the +! number of vertices for a a D-simplex (D+1). +! 20 : The second dimension of the output array WEIGHTS does not match the +! number of interpolation points M. +! 21 : The size of the error array IERR does not match the number of +! interpolation points M. +! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. +! 23 : The first dimension of INTERP_IN does not match the first +! dimension of INTERP_OUT. +! 24 : The second dimension of INTERP_IN does not match the number of +! data points PTS. +! 25 : The second dimension of INTERP_OUT does not match the number of +! interpolation points M. +! 26 : The budget supplied in IBUDGET does not contain a positive +! integer. +! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. +! 28 : The size of the RNORM output array does not match the number of +! interpolation points M. +! +! 30 : Two or more points in the data set PTS are too close together with +! respect to the working precision (EPS), which would result in a +! numerically degenerate simplex. +! 31 : All the data points in PTS lie in some lower dimensional linear +! manifold (up to the working precision), and no valid triangulation +! exists. +! 40 : An error caused DELAUNAYSPARSES to terminate before this value could +! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may +! contain garbage values. +! +! 50 : A memory allocation error occurred while allocating the work array +! WORK. +! +! 60 : The budget was exceeded before the algorithm converged on this +! value. If the dimension is high, try increasing IBUDGET. This +! error can also be caused by a working precision EPS that is too +! small for the conditioning of the problem. +! +! 61 : A value that was judged appropriate later caused LAPACK to encounter a +! singularity. Try increasing the value of EPS. +! +! 70 : Allocation error for the extrapolation work arrays. +! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection +! of an extrapolation point onto the convex hull. +! 72 : The SLATEC subroutine DWNNLS has reported a usage error. +! +! The errors 72, 80--83 should never occur, and likely indicate a +! compiler bug or hardware failure. +! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. +! 81 : The LAPACK subroutine DGETRF has reported an illegal value. +! 82 : The LAPACK subroutine DGETRS has reported an illegal value. +! 83 : The LAPACK subroutine DORMQR has reported an illegal value. +! +! +! Optional arguments: +! +! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of +! the data points in PTS on input. The first dimension of INTERP_IN is +! inferred to be the dimension of these response vectors, and the +! second dimension must match N. If present, the response values will +! be computed for each interpolation point in Q, and stored in INTERP_OUT, +! which therefore must also be present. If both INTERP_IN and INTERP_OUT +! are omitted, only the containing simplices and convex combination +! weights are returned. +! +! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each +! interpolation point in Q on output. The first dimension of INTERP_OUT +! must match the first dimension of INTERP_IN, and the second dimension +! must match M. If present, the response values at each interpolation +! point are computed as a convex combination of the response values +! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing +! that interpolation point. Therefore, if INTERP_OUT is present, then +! INTERP_IN must also be present. If both are omitted, only the +! simplices and convex combination weights are returned. +! +! EPS contains the real working precision for the problem on input. By default, +! EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff for the +! machine. In general, any values that differ by less than EPS are judged +! as equal, and any weights that are greater than -EPS are judged as +! nonnegative. EPS cannot take a value less than the default value of +! \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, the default +! value will be used instead automatically. +! +! EXTRAP contains the real maximum extrapolation distance (relative to the +! diameter of PTS) on input. Interpolation at a point outside the convex +! hull of PTS is done by projecting that point onto the convex hull, and +! then doing normal Delaunay interpolation at that projection. +! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) +! units outside the convex hull of PTS will not be done and an error code +! of 2 will be returned. Note that computing the projection can be +! expensive. Setting EXTRAP=0 will cause all extrapolation points to be +! ignored without ever computing a projection. By default, EXTRAP=0.1 +! (extrapolate by up to 10% of the diameter of PTS). +! +! RNORM(1:M) contains the real unscaled projection (2-norm) distances from +! any projection computations on output. If not present, these distances +! are still computed for each extrapolation point, but are never returned. +! +! IBUDGET on input contains the integer budget for performing flips while +! iterating toward the simplex containing each interpolation point in +! Q. This prevents DELAUNAYSPARSES from falling into an infinite loop when +! an inappropriate value of EPS is given with respect to the problem +! conditioning. By default, IBUDGET=50000. However, for extremely +! high-dimensional problems and pathological inputs, the default value +! may be insufficient. +! +! CHAIN is a logical input argument that determines whether a new first +! simplex should be constructed for each interpolation point +! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." +! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not +! recommended, unless the size of the triangulation is relatively small +! or the interpolation points are known to be tightly clustered. +! +! EXACT is a logical input argument that determines whether the exact +! diameter should be computed and whether a check for duplicate data +! points should be performed in advance. When EXACT=.FALSE., the +! diameter of PTS is approximated by twice the distance from the +! barycenter of PTS to the farthest point in PTS, and no check is +! done to find the closest pair of points, which could result in hard +! to find bugs later on. When EXACT=.TRUE., the exact diameter is +! computed and an error is returned whenever PTS contains duplicate +! values up to the precision EPS. By default EXACT=.TRUE., but setting +! EXACT=.FALSE. could result in significant speedup when N is large. +! It is strongly recommended that most users leave EXACT=.TRUE., as +! setting EXACT=.FALSE. could result in input errors that are difficult +! to identify. Also, the diameter approximation could be wrong by up to +! a factor of two. +! +! +! Subroutines and functions directly referenced from BLAS are +! DDOT, DGEMV, DNRM2, DTRSM, +! and from LAPACK are +! DGEQP3, DGETRF, DGETRS, DORMQR. +! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its +! SLATEC dependencies have been slightly edited to comply with the Fortran +! 2008 standard, with all print statements and references to stderr being +! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 +! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS +! Algorithm 777) is used for the real data type. The REAL_PRECISION module, +! DELAUNAYSPARSES, and DWNNLS and its dependencies comply with the Fortran +! 2008 standard. +! +! Primary Author: Tyler H. Chang +! Last Update: March, 2020 +! +USE REAL_PRECISION, ONLY : R8 +IMPLICIT NONE + +! Input arguments. +INTEGER, INTENT(IN) :: D, N +REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) ! Rescaled on output. +INTEGER, INTENT(IN) :: M +REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) ! Rescaled on output. +! Output arguments. +INTEGER, INTENT(OUT) :: SIMPS(:,:) +REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) +INTEGER, INTENT(OUT) :: IERR(:) +! Optional arguments. +REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) +REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) +REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP +REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) +INTEGER, INTENT(IN), OPTIONAL :: IBUDGET +LOGICAL, INTENT(IN), OPTIONAL :: CHAIN +LOGICAL, INTENT(IN), OPTIONAL :: EXACT + +! Local copies of optional input arguments. +REAL(KIND=R8) :: EPSL, EXTRAPL +INTEGER :: IBUDGETL +LOGICAL :: CHAINL, EXACTL + +! Local variables. +INTEGER :: I, J, K ! Loop iteration variables. +INTEGER :: IEXTRAPS ! Extrapolation budget. +INTEGER :: ITMP, JTMP ! Temporary variables for swapping, looping, etc. +INTEGER :: LWORK ! Size of the work array. +INTEGER :: MI ! Index of current interpolation point. +REAL(KIND=R8) :: CURRRAD ! Radius of the current circumsphere. +REAL(KIND=R8) :: MINRAD ! Minimum circumsphere radius observed. +REAL(KIND=R8) :: PTS_DIAM ! Scaled diameter of data set. +REAL(KIND=R8) :: PTS_SCALE ! Data scaling factor. +REAL(KIND=R8) :: RNORML ! Euclidean norm of the projection residual. +REAL(KIND=R8) :: SIDE1, SIDE2 ! Signs (+/-1) denoting sides of a facet. + +! Local arrays, requiring O(d^2) additional memory. +INTEGER :: IPIV(D) ! Pivot indices. +INTEGER :: SEED(D+1) ! Copy of the SEED simplex. Only used if CHAIN = .TRUE. +REAL(KIND=R8) :: AT(D,D) ! The transpose of A, the linear coefficient matrix. +REAL(KIND=R8) :: B(D) ! The RHS of a linear system. +REAL(KIND=R8) :: CENTER(D) ! The circumcenter of a simplex. +REAL(KIND=R8) :: LQ(D,D) ! Holds LU or QR factorization of AT. +REAL(KIND=R8) :: PLANE(D+1) ! The hyperplane containing a facet. +REAL(KIND=R8) :: PRGOPT_DWNNLS(1) ! Options array for DWNNLS. +REAL(KIND=R8) :: PROJ(D) ! The projection of the current iterate. +REAL(KIND=R8) :: TAU(D) ! Householder reflector constants. +REAL(KIND=R8) :: X(D) ! The solution to a linear system. + +! Extrapolation work arrays are only allocated if DWNNLS is called. +INTEGER, ALLOCATABLE :: IWORK_DWNNLS(:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: W_DWNNLS(:,:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: WORK(:) ! Allocated with size LWORK. +REAL(KIND=R8), ALLOCATABLE :: WORK_DWNNLS(:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: X_DWNNLS(:) ! Only for DWNNLS. + +! External functions and subroutines. +REAL(KIND=R8), EXTERNAL :: DDOT ! Inner product (BLAS). +REAL(KIND=R8), EXTERNAL :: DNRM2 ! Euclidean norm (BLAS). +EXTERNAL :: DGEMV ! General matrix vector multiply (BLAS) +EXTERNAL :: DGEQP3 ! Perform a QR factorization with column pivoting (LAPACK). +EXTERNAL :: DGETRF ! Perform a LU factorization with partial pivoting (LAPACK). +EXTERNAL :: DGETRS ! Use the output of DGETRF to solve a linear system (LAPACK). +EXTERNAL :: DORMQR ! Apply householder reflectors to a matrix (LAPACK). +EXTERNAL :: DTRSM ! Perform a triangular solve (BLAS). +EXTERNAL :: DWNNLS ! Solve an inequality constrained least squares problem + ! (SLATEC). + +! Check for input size and dimension errors. +IF (D < 1) THEN ! The dimension must satisfy D > 0. + IERR(:) = 10; RETURN; END IF +IF (N < D+1) THEN ! Must have at least D+1 data points. + IERR(:) = 11; RETURN; END IF +IF (M < 1) THEN ! Must have at least one interpolation point. + IERR(:) = 12; RETURN; END IF +IF (SIZE(PTS,1) .NE. D) THEN ! Dimension of PTS array should match. + IERR(:) = 13; RETURN; END IF +IF (SIZE(PTS,2) .NE. N) THEN ! Number of data points should match. + IERR(:) = 14; RETURN; END IF +IF (SIZE(Q,1) .NE. D) THEN ! Dimension of Q should match. + IERR(:) = 15; RETURN; END IF +IF (SIZE(Q,2) .NE. M) THEN ! Number of interpolation points should match. + IERR(:) = 16; RETURN; END IF +IF (SIZE(SIMPS,1) .NE. D+1) THEN ! Need space for D+1 vertices per simplex. + IERR(:) = 17; RETURN; END IF +IF (SIZE(SIMPS,2) .NE. M) THEN ! There will be M output simplices. + IERR(:) = 18; RETURN; END IF +IF (SIZE(WEIGHTS,1) .NE. D+1) THEN ! There will be D+1 weights per simplex. + IERR(:) = 19; RETURN; END IF +IF (SIZE(WEIGHTS,2) .NE. M) THEN ! One vector of weights per simplex. + IERR(:) = 20; RETURN; END IF +IF (SIZE(IERR) .NE. M) THEN ! An error flag for each interpolation point. + IERR(:) = 21; RETURN; END IF + +! Check for optional arguments. +IF (PRESENT(INTERP_IN) .NEQV. PRESENT(INTERP_OUT)) THEN + IERR(:) = 22; RETURN; END IF +IF (PRESENT(INTERP_IN)) THEN ! Sizes must agree. + IF (SIZE(INTERP_IN,1) .NE. SIZE(INTERP_OUT,1)) THEN + IERR(:) = 23 ; RETURN; END IF + IF(SIZE(INTERP_IN,2) .NE. N) THEN + IERR(:) = 24; RETURN; END IF + IF (SIZE(INTERP_OUT,2) .NE. M) THEN + IERR(:) = 25; RETURN; END IF + INTERP_OUT(:,:) = 0.0_R8 ! Initialize output to zeros. +END IF +EPSL = SQRT(EPSILON(0.0_R8)) ! Get the machine unit roundoff constant. +IF (PRESENT(EPS)) THEN + IF (EPSL < EPS) THEN ! If the given precision is too small, ignore it. + EPSL = EPS + END IF +END IF +IF (PRESENT(IBUDGET)) THEN + IBUDGETL = IBUDGET ! Use the given budget if present. + IF (IBUDGETL < 1) THEN + IERR(:) = 26; RETURN; END IF +ELSE + IBUDGETL = 50000 ! Default value for budget. +END IF +IF (PRESENT(EXTRAP)) THEN + EXTRAPL = EXTRAP + IF (EXTRAPL < 0) THEN ! Check that the extrapolation distance is legal. + IERR(:) = 27; RETURN; END IF +ELSE + EXTRAPL = 0.1_R8 ! Default extrapolation distance (for normalized points). +END IF +IF (PRESENT(RNORM)) THEN + IF (SIZE(RNORM,1) .NE. M) THEN ! The length of the array must match. + IERR(:) = 28; RETURN; END IF + RNORM(:) = 0.0_R8 ! Initialize output to zeros. +END IF +IF (PRESENT(CHAIN)) THEN + CHAINL = CHAIN ! Turn chaining on, if necessarry. + SEED(:) = 0 ! Initialize SEED in case it is needed. +ELSE + CHAINL = .FALSE. +END IF +IF (PRESENT(EXACT)) THEN + EXACTL = EXACT ! Set error checking and exact diameter computations. +ELSE + EXACTL = .TRUE. +END IF + +! Scale and center the data points and interpolation points. +CALL RESCALE(MINRAD, PTS_DIAM, PTS_SCALE) +IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. + IERR(:) = 30; RETURN; END IF + +! Query DGEQP3 for optimal work array size (LWORK). +LWORK = -1 +CALL DGEQP3(D,D,LQ,D,IPIV,TAU,B,LWORK,IERR(1)) +LWORK = INT(B(1)) ! Compute the optimal work array size. +ALLOCATE(WORK(LWORK), STAT=I) ! Allocate WORK to size LWORK. +IF (I .NE. 0) THEN ! Check for memory allocation errors. + IERR(:) = 50; RETURN; END IF + +! Initialize all error codes to "TBD" values. +IERR(:) = 40 + +! Outer loop over all interpolation points (in Q). +OUTER : DO MI = 1, M + + ! Check if this interpolation point was already found. + IF (IERR(MI) .EQ. 0) CYCLE OUTER + + ! Initialize the projection and reset the residual. + PROJ(:) = Q(:,MI) + RNORML = 0.0_R8 + + ! Check if extrapolation is enabled. + IF (EXTRAPL < EPSL) THEN + IEXTRAPS = -1 ! If not, set the extrapolation budget negative. + ELSE + IEXTRAPS = 1 ! Allow for exactly one projection for this point. + END IF + + ! If there is no useable seed or if chaining is turned off, then make a new + ! simplex. + IF( (.NOT. CHAINL) .OR. SEED(1) .EQ. 0) THEN + CALL MAKEFIRSTSIMP() + IF(IERR(MI) .NE. 0) CYCLE OUTER + ! Otherwise, use the seed. + ELSE + ! Copy the seed to the current simplex. + SIMPS(:,MI) = SEED(:) + ! Rebuild the linear system. + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + + ! Inner loop searching for a simplex containing the point Q(:,MI). + INNER : DO K = 1, IBUDGETL + + ! If chaining is on, save each good simplex as the next seed. + IF (CHAINL) SEED(:) = SIMPS(:,MI) + + ! Check if the current simplex contains Q(:,MI). + IF (PTINSIMP()) EXIT INNER + IF (IERR(MI) .NE. 0) CYCLE OUTER ! Check for an error flag. + + ! Swap out the least weighted vertex, but save its value in case it + ! needs to be restored later. + JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) + ITMP = SIMPS(JTMP,MI) + SIMPS(JTMP,MI) = SIMPS(D+1,MI) + + ! If the least weighted vertex (index JTMP) is not the first vertex, + ! then just drop row (JTMP-1) from the linear system (corresponding + ! to column (JTMP-1) of A^T). + IF(JTMP .NE. 1) THEN + AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) + ! However, if JTMP = 1, then both A^T and B must be reconstructed. + ELSE + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + + ! Compute the next simplex (do one flip). + CALL MAKESIMPLEX() + IF (IERR(MI) .NE. 0) CYCLE OUTER + + ! If no vertex was found, then this is an extrapolation point. + IF (SIMPS(D+1,MI) .EQ. 0) THEN + + ! If extrapolation is not allowed (EXTRAP=0), do not proceed. + IF (IEXTRAPS < 0) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! Set the error flag and skip this point. + IERR(MI) = 2; CYCLE OUTER + + ! If extrapolation is allowed (EXTRAP>0), check the budget. + ELSE IF (IEXTRAPS .EQ. 0) THEN + ! A second projection has been attempted. This code is rarely + ! called, except in extreme cases involving nearly singular + ! simplices near the convex hull of P. + + ! Swap the weights to match the simplex indices, and zero the + ! most negative weight. + WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) + WEIGHTS(D+1,MI) = 0.0_R8 + ! Loop through all the remaining facets from which Q(:,MI) is + ! visible, and attempt to flip across each one. + DO WHILE (SIMPS(D+1,MI) .EQ. 0) + ! Restore the previous simplex and linear system. + SIMPS(D+1,MI) = ITMP + AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + ! Find the next most negative weight. + JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) + ! Check if WEIGHTS(JTMP,MI) .GE. 0. + IF (WEIGHTS(JTMP,MI) .GE. -EPSL) THEN + ! There is no other direction to flip, so Q(:,MI) must be + ! within EPSL of the current simplex. + ! Project Q(:,MI) onto the current simplex. + + ! Since at least one projection has already been done, + ! the work arrays have already been allocated. + PRGOPT_DWNNLS(1) = 1.0_R8 + IWORK_DWNNLS(1) = 6*D + 6 + IWORK_DWNNLS(2) = 2*D + 2 + ! Set equality constraint. + W_DWNNLS(1,1:D+2) = 1.0_R8 + ! Populate LS coefficient matrix and RHS. + FORALL (I=1:D+1) W_DWNNLS(2:D+1,I) = PTS(:,SIMPS(I,MI)) + W_DWNNLS(2:D+1,D+2) = PROJ(:) + ! Project onto the current simplex. + CALL DWNNLS(W_DWNNLS, D+1, 1, D, D+1, 0, PRGOPT_DWNNLS, & + WEIGHTS(:,MI), WORK(1), IERR(MI), IWORK_DWNNLS, & + WORK_DWNNLS) + IF (IERR(MI) .EQ. 1) THEN ! Failure to converge. + IERR(MI) = 71; CYCLE OUTER + ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. + IERR(MI) = 72; CYCLE OUTER + END IF + ! A solution has been found; return it. + EXIT INNER + END IF + ! Otherwise, swap the vertices. + ITMP = SIMPS(JTMP,MI) + SIMPS(JTMP,MI) = SIMPS(D+1,MI) + ! Swap the weights to match, and zero the most negative weight. + WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) + WEIGHTS(D+1,MI) = 0.0_R8 + ! If the least weighted vertex (index JTMP) is not the first + ! vertex, then just drop row (JTMP-1) from the linear system + ! (corresponding to column (JTMP-1) of A^T). + IF (JTMP .NE. 1) THEN + AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) + ! However, if JTMP=1, then both A^T and B must be reconstructed. + ELSE + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + ! Compute another simplex (try to flip again). + CALL MAKESIMPLEX(); IF (IERR(MI) .NE. 0) CYCLE OUTER + END DO + ! If the loop terminates, then a good direction was found. + ! Resume the visibility walk as normal. + CYCLE INNER + END IF + + ! Otherwise, project the extrapolation point onto the convex hull. + CALL PROJECT() + IF (IERR(MI) .NE. 0) CYCLE OUTER + + ! Check the value of RNORML for over-extrapolation. + IF (RNORML > EXTRAPL * PTS_DIAM) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! If present, record the unscaled RNORM output. + IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE + ! Set the error flag and skip this point. + IERR(MI) = 2; CYCLE OUTER + END IF + + ! Otherwise, restore the previous simplex and continue with the + ! projected value. + SIMPS(D+1,MI) = ITMP + AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + IEXTRAPS = IEXTRAPS - 1 ! Decrement the budget. + END IF + + ! End of inner loop for finding each interpolation point. + END DO INNER + + ! Check for budget violation conditions. + IF (K > IBUDGETL) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! Set the error flag and skip this point. + IERR(MI) = 60; CYCLE OUTER + END IF + + ! If the residual is nonzero, set the extrapolation flag. + IF (RNORML > EPSL) IERR(MI) = 1 + + ! If present, record the RNORM output. + IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE + +END DO OUTER ! End of outer loop over all interpolation points. + +! If INTERP_IN and INTERP_OUT are present, compute all values f(q). +IF (PRESENT(INTERP_IN)) THEN + ! Loop over all interpolation points. + DO MI = 1, M + ! Check for errors. + IF (IERR(MI) .LE. 1) THEN + ! Compute the weighted sum of vertex response values. + DO K = 1, D+1 + INTERP_OUT(:,MI) = INTERP_OUT(:,MI) & + + INTERP_IN(:,SIMPS(K,MI)) * WEIGHTS(K,MI) + END DO + END IF + END DO +END IF + +! Free dynamic work arrays. +DEALLOCATE(WORK) +IF (ALLOCATED(IWORK_DWNNLS)) DEALLOCATE(IWORK_DWNNLS) +IF (ALLOCATED(WORK_DWNNLS)) DEALLOCATE(WORK_DWNNLS) +IF (ALLOCATED(W_DWNNLS)) DEALLOCATE(W_DWNNLS) +IF (ALLOCATED(X_DWNNLS)) DEALLOCATE(X_DWNNLS) + +RETURN + +CONTAINS ! Internal subroutines and functions. + +SUBROUTINE MAKEFIRSTSIMP() +! Iteratively construct the first simplex by choosing points that +! minimize the radius of the smallest circumball. Let P_1, P_2, ..., P_K +! denote the current set of vertices for the simplex. Let P* denote the +! candidate vertex to be added to the simplex. Let CENTER denote the +! circumcenter of the simplex. Then +! +! X = CENTER - P_1 +! +! is given by the minimum norm solution to the underdetermined linear system +! +! A X = B, where +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_K - P_1, P* - P_1 ] and +! B = [ /2, /2, ..., /2 ]^T. +! +! Then the radius of the smallest circumsphere is CURRRAD = \| X \|, +! and the next vertex is given by P_{K+1} = argmin_{P*} CURRRAD, where P* +! ranges over points in PTS that are not already a vertex of the simplex. +! +! On output, this subroutine fully populates the matrix A^T and vector B, +! and fills SIMPS(:,MI) with the indices of a valid Delaunay simplex. + +! Find the first point, i.e., the closest point to Q(:,MI). +SIMPS(:,MI) = 0 +MINRAD = HUGE(0.0_R8) +DO I = 1, N + ! Check the distance to Q(:,MI). + CURRRAD = DNRM2(D, PTS(:,I) - PROJ(:), 1) + IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(1,MI) = I; END IF +END DO +! Find the second point, i.e., the closest point to PTS(:,SIMPS(1,MI)). +MINRAD = HUGE(0.0_R8) +DO I = 1, N + ! Skip repeated vertices. + IF (I .EQ. SIMPS(1,MI)) CYCLE + ! Check the diameter of the resulting circumsphere. + CURRRAD = DNRM2(D, PTS(:,I)-PTS(:,SIMPS(1,MI)), 1) + IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(2,MI) = I; END IF +END DO +IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. + IERR(MI) = 30; RETURN; END IF +! Set up the first row of the linear system. +AT(:,1) = PTS(:,SIMPS(2,MI)) - PTS(:,SIMPS(1,MI)) +B(1) = DDOT(D, AT(:,1), 1, AT(:,1), 1) / 2.0_R8 +! Loop to collect the remaining D-1 vertices for the first simplex. +DO I = 2, D + ! For numerical stability, refactor A^T P = Q R for the next iteration. + LQ(:,1:I-1) = AT(:,1:I-1) + CALL DGEQP3(D, I-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 80; RETURN + END IF + ! Set the RHS to P^T B. + FORALL (ITMP = 1:I-1) X(ITMP) = B(IPIV(ITMP)) + ! Solve R^T Q^T X = P^T B for Q^T X, and save for later. + CALL DTRSM('L', 'U', 'T', 'N', I-1, 1, 1.0_R8, LQ, D, X, D) + ! Make a copy for computing the current center. + CENTER(1:I-1) = X(1:I-1) + CENTER(I:D) = 0.0_R8 + ! Apply Q from the left. + CALL DORMQR('L', 'N', D, 1, I-1, LQ, D, TAU, CENTER, D, WORK, & + LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 83; RETURN + END IF + CENTER = CENTER + PTS(:,SIMPS(1,MI)) + ! Re-initialize the radius for each iteration. + MINRAD = HUGE(0.0_R8) + ! Check each point P* in PTS. + DO J = 1, N + ! Check that this point is not already in the simplex. + IF (ANY(SIMPS(:,MI) .EQ. J)) CYCLE + ! If PTS(:,J) is more than twice MINRAD from CENTER, do a quick skip. + IF (DNRM2(D, CENTER - PTS(:,J), 1) > 2.0_R8 * MINRAD) CYCLE + ! Perform a rank-1 update to the current QR factorization of A^T by + ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI)) by Q^T and storing in the + ! final column of R. + LQ(:,I) = PTS(:,J) - PTS(:,SIMPS(1,MI)) + CALL DORMQR('L', 'T', D, 1, I-1, LQ(:,1:I-1), D, TAU, LQ(:,I), D, & + WORK, LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 83; RETURN + END IF + ! Implicitly apply the next Householder reflector. + LQ(I,I) = DNRM2(D+1-I, LQ(I:D,I), 1) + IF (LQ(I,I) < EPSL) THEN ! A is rank-deficient. + CYCLE ! If rank-deficient, skip this point. + END IF + ! Update the current radius by \| Q^T X \| = \| X \|. + WORK(1:I-1) = (LQ(1:I-1,I) / 2.0_R8) - X(1:I-1) + WORK(I) = LQ(I,I) / 2.0_R8 + X(I) = DDOT(I, LQ(1:I,I), 1, WORK(1:I), 1) / LQ(I,I) + CURRRAD = DNRM2(I, X(1:I), 1) + ! Compare the last component of Q^T X to the current minimum. + IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMPS(I+1,MI) = J; END IF + END DO + ! Check that a point was found. If not, then all the points must lie in a + ! lower dimensional linear manifold (error case). + IF (SIMPS(I+1,MI) .EQ. 0) THEN; IERR(MI) = 31; RETURN; END IF + ! If all operations were successful, add the best P* to the linear system. + AT(:,I) = PTS(:,SIMPS(I+1,MI)) - PTS(:,SIMPS(1,MI)) + B(I) = DDOT(D, AT(:,I), 1, AT(:,I), 1) / 2.0_R8 +END DO +IERR(MI) = 0 ! Set error flag to 'success' for a normal return. +RETURN +END SUBROUTINE MAKEFIRSTSIMP + +SUBROUTINE MAKESIMPLEX() +! Given a Delaunay facet F whose containing hyperplane does not contain +! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' +! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F +! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the +! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly +! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing +! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices +! P_1, P_2, ..., P_D, P*. Then +! +! X = CENTER - P_1 +! +! is given by the solution to the nonsingular linear system +! +! A X = B where +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and +! B = [ /2, /2, ..., /2 ]^T. +! +! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the +! candidate P* that satisfies both of the following: +! +! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) +! must be on the same side of PLANE. +! +! 2) The circumball about CENTER must not contain any points in PTS in its +! interior (Delaunay property). +! +! The above are necessary and sufficient conditions for flipping the +! Delaunay simplex, given that F is indeed a Delaunay facet. +! +! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices +! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex +! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and +! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were +! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an +! extrapolation point (not a convex combination of points in PTS). + +! Compute the hyperplane PLANE. +CALL MAKEPLANE() +IF(IERR(MI) .NE. 0) RETURN ! Check for errors. +! Compute the sign for the side of PLANE containing Q(:,MI). +SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) +SIDE1 = SIGN(1.0_R8,SIDE1) +! Initialize the center, radius, and simplex. +SIMPS(D+1,MI) = 0 +CENTER(:) = 0.0_R8 +MINRAD = HUGE(0.0_R8) +! If D=1, just check for the closest point on SIDE1 of PTS(:,SIMPS(1,MI)). +IF (D .EQ. 1) THEN + ! Loop through all points P* in PTS. + DO I = 1, N + ! Check that P* is on the appropriate halfspace. + SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 + IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE + ! Check that P* is closer than the current solution. + IF (SIDE2 > MINRAD) CYCLE + ! Update the minimum distance and save the index I. + MINRAD = SIDE2 + SIMPS(2,MI) = I + END DO + IERR(MI) = 0 ! Reset the error flag to 'success' code. + ! Check for extrapolation condition. + IF(SIMPS(2,MI) .EQ. 0) RETURN + ! Add new point to the linear system. + AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) + B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 + RETURN +END IF +! Set the RHS to P^T B. +FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) +! Solve R^T Q^T X = P^T B for Q^T X. +CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) +! Loop through all points P* in PTS. +DO I = 1, N + ! Check that P* is inside the current ball. + IF (DNRM2(D, PTS(:,I) - CENTER(:), 1) > MINRAD) CYCLE ! If not, skip. + ! Check that P* is on the appropriate halfspace. + SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) + IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE ! If not, skip. + ! Perform a rank-1 update to the current QR factorization of A^T by + ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the + ! final column of R. + LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) + CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & + LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 83; RETURN + END IF + ! Update the last element of Q^T X. + WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) + WORK(D) = LQ(D,D) / 2.0_R8 + CENTER(1:D-1) = X(1:D-1) + CENTER(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) + ! Get the center by applying Q to the solution. + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER, D, WORK, LWORK, & + IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 83; RETURN + END IF + ! Update the new radius, center, and simplex. + MINRAD = DNRM2(D, CENTER, 1) + CENTER(:) = CENTER(:) + PTS(:,SIMPS(1,MI)) + SIMPS(D+1,MI) = I +END DO +IERR(MI) = 0 ! Reset the error flag to 'success' code. +! Check for extrapolation condition. +IF(SIMPS(D+1,MI) .EQ. 0) RETURN +! Add new point to the linear system. +AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) +B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 +RETURN +END SUBROUTINE MAKESIMPLEX + +SUBROUTINE MAKEPLANE() +! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed +! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. +! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal +! vector is any nonzero vector in ker A, where the matrix +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. +! +! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR +! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. +! Then the last column of Q is orthogonal to the range of A^T, and in ker A. +! +! Upon output, PLANE(1:D) contains the normal vector c and PLANE(D+1) +! contains \alpha defining the plane. Also, LQ, IPIV, and TAU define a QR +! factorizaton of the first D-1 columns of A^T. + +IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. + ! Compute the QR factorization. + IPIV=0 + LQ = AT + CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 80; RETURN + END IF + ! The nullspace is given by the last column of Q. + PLANE(1:D-1) = 0.0_R8 + PLANE(D) = 1.0_R8 + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & + LWORK, IERR(MI)) + IF(IERR(MI) < 0) THEN ! LAPACK illegal input error. + IERR(MI) = 83; RETURN + END IF + ! Calculate the constant \alpha defining the plane. + PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) +ELSE ! Special case where D=1. + PLANE(1) = 1.0_R8 + PLANE(2) = PTS(1,SIMPS(1,MI)) +END IF +RETURN +END SUBROUTINE MAKEPLANE + +FUNCTION PTINSIMP() RESULT(TF) +! Determine if any interpolation points are in the current simplex, whose +! vertices P_1, P_2, ..., P_{D+1} are indexed by SIMPS(:,MI). These +! vertices determine a positive cone with generators V_I = P_{I+1} - P_1, +! I = 1, ..., D. For each interpolation point Q* in Q, Q* - P_1 can be +! expressed as a unique linear combination of the V_I. If all these linear +! weights are nonnegative and sum to less than or equal to 1.0, then Q* is +! in the simplex with vertices {P_I}_{I=1}^{D+1}. +! +! If any interpolation points in Q are contained in the simplex whose +! vertices are indexed by SIMPS(:,MI), then those points are marked as solved +! and the values of SIMPS and WEIGHTS are updated appropriately. On output, +! WEIGHTS(:,MI) contains the affine weights for producing Q(:,MI) as an +! affine combination of the points in PTS indexed by SIMPS(:,MI). If these +! weights are nonnegative, then PTINSIMP() returns TRUE. + +! Initialize the return value and local variables. +LOGICAL :: TF ! True/False value. +TF = .FALSE. + +! Compute the LU factorization of the matrix A^T, whose columns are +! P_{I+1} - P_1. +LQ = AT +CALL DGETRF(D, D, LQ, D, IPIV, IERR(MI)) +IF (IERR(MI) < 0) THEN ! LAPACK illegal input. + IERR(MI) = 81; RETURN +ELSE IF (IERR(MI) > 0) THEN ! Rank-deficiency detected. + IERR(MI) = 61; RETURN +END IF +! Solve A^T w = WORK to get the affine weights for Q(:,MI) or its projection. +WORK(1:D) = PROJ(:) - PTS(:,SIMPS(1,MI)) +CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(1:D), D, IERR(MI)) +IF (IERR(MI) < 0) THEN ! LAPACK illegal input. + IERR(MI) = 82; RETURN +END IF +WEIGHTS(2:D+1,MI) = WORK(1:D) +WEIGHTS(1,MI) = 1.0_R8 - SUM(WEIGHTS(2:D+1,MI)) +! Check if the weights for Q(:,MI) are nonnegative. +IF (ALL(WEIGHTS(:,MI) .GE. -EPSL)) TF = .TRUE. + +! Compute the affine weights for the rest of the interpolation points. +DO I = MI+1, M + ! Check that no solution has already been found. + IF (IERR(I) .NE. 40) CYCLE + ! Solve A^T w = WORK to get the affine weights for Q(:,I). + WORK(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) + CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(2:D+1), D, ITMP) + IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. + ! Check if the weights define a convex combination. + WORK(1) = 1.0_R8 - SUM(WORK(2:D+1)) + IF (ALL(WORK(1:D+1) .GE. -EPSL)) THEN + ! Copy the simplex indices and weights then flag as complete. + SIMPS(:,I) = SIMPS(:,MI) + WEIGHTS(:,I) = WORK(1:D+1) + IERR(I) = 0 + END IF +END DO +RETURN +END FUNCTION PTINSIMP + +SUBROUTINE PROJECT() +! Project a point outside the convex hull of the point set onto the convex hull +! by solving an inequality constrained least squares problem. The solution to +! the least squares problem gives the projection as a convex combination of the +! data points. The projection can then be computed by performing a matrix +! vector multiplication. + +! Allocate work arrays. +IF (.NOT. ALLOCATED(IWORK_DWNNLS)) THEN + ALLOCATE(IWORK_DWNNLS(D+1+N), STAT=IERR(MI)) + IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF +END IF +IF (.NOT. ALLOCATED(WORK_DWNNLS)) THEN + ALLOCATE(WORK_DWNNLS(D+1+N*5), STAT=IERR(MI)) + IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF +END IF +IF (.NOT. ALLOCATED(W_DWNNLS)) THEN + ALLOCATE(W_DWNNLS(D+1,N+1), STAT=IERR(MI)) + IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF +END IF +IF (.NOT. ALLOCATED(X_DWNNLS)) THEN + ALLOCATE(X_DWNNLS(N), STAT=IERR(MI)) + IF(IERR(MI) .NE. 0) THEN; IERR(MI) = 70; RETURN; END IF +END IF + +! Initialize work array and settings values. +PRGOPT_DWNNLS(1) = 1.0_R8 +IWORK_DWNNLS(1) = D+1+5*N +IWORK_DWNNLS(2) = D+1+N +W_DWNNLS(1, :) = 1.0_R8 ! Set convexity (equality) constraint. +W_DWNNLS(2:D+1,1:N) = PTS(:,:) ! Copy data points. +W_DWNNLS(2:D+1,N+1) = PROJ(:) ! Copy extrapolation point. +! Compute the solution to the inequality constrained least squares problem to +! get the projection coefficients. +CALL DWNNLS(W_DWNNLS, D+1, 1, D, N, 0, PRGOPT_DWNNLS, X_DWNNLS, RNORML, & + IERR(MI), IWORK_DWNNLS, WORK_DWNNLS) +IF (IERR(MI) .EQ. 1) THEN ! Failure to converge. + IERR(MI) = 71; RETURN +ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. + IERR(MI) = 72; RETURN +END IF +! Zero all weights that are approximately zero and renormalize the sum. +WHERE (X_DWNNLS < EPSL) X_DWNNLS = 0.0_R8 +X_DWNNLS(:) = X_DWNNLS(:) / SUM(X_DWNNLS) +! Compute the actual projection via matrix vector multiplication. +CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) +RNORML = DNRM2(D, PROJ(:) - Q(:,MI), 1) +RETURN +END SUBROUTINE PROJECT + +SUBROUTINE RESCALE(MINDIST, DIAMETER, SCALE) +! Rescale and transform data to be centered at the origin with unit +! radius. This subroutine has O(n^2) complexity. +! +! On output, PTS and Q have been rescaled and shifted. All the data +! points in PTS are centered with unit radius, and the points in Q +! have been shifted and scaled in relation to PTS. +! +! MINDIST is a real number containing the (scaled) minimum distance +! between any two data points in PTS. +! +! DIAMETER is a real number containing the (scaled) diameter of the +! data set PTS. +! +! SCALE contains the real factor used to transform the data and +! interpolation points: scaled value = (original value - +! barycenter of data points)/SCALE. + +! Output arguments. +REAL(KIND=R8), INTENT(OUT) :: MINDIST, DIAMETER, SCALE + +! Local variables. +REAL(KIND=R8) :: PTS_CENTER(D) ! The center of the data points PTS. +REAL(KIND=R8) :: DISTANCE ! The current distance. + +! Initialize local values. +MINDIST = HUGE(0.0_R8) +DIAMETER = 0.0_R8 +SCALE = 0.0_R8 + +! Compute barycenter of all data points. +PTS_CENTER(:) = SUM(PTS(:,:), DIM=2)/REAL(N, KIND=R8) +! Center the points. +FORALL (I = 1:N) PTS(:,I) = PTS(:,I) - PTS_CENTER(:) +! Compute the scale factor (for unit radius). +DO I = 1, N ! Cycle through all points again. + DISTANCE = DNRM2(D, PTS(:,I), 1) ! Compute the distance from the center. + IF (DISTANCE > SCALE) THEN ! Compare to the current radius. + SCALE = DISTANCE + END IF +END DO +! Scale the points to unit radius. +PTS = PTS / SCALE +! Also transform Q similarly. +FORALL (I = 1:M) Q(:,I) = (Q(:,I) - PTS_CENTER(:)) / SCALE +! Compute the minimum and maximum distances. +IF (EXACTL) THEN + ! If exact error error checking is turned on, then compute the DIAMETER + ! and MINDIST values. + DO I = 1, N ! Cycle through all pairs of points. + DO J = I + 1, N + DISTANCE = DNRM2(D, PTS(:,I) - PTS(:,J), 1) ! Compute the distance. + IF (DISTANCE > DIAMETER) THEN ! Compare to the current diameter. + DIAMETER = DISTANCE + END IF + IF (DISTANCE < MINDIST) THEN ! Compare to the current minimum distance. + MINDIST = DISTANCE + END IF + END DO + END DO +ELSE + ! If exact error checking is turned off, then the diameter is approximately + ! 2.0 after rescaling and centering the points. The MINDIST is not computed. + DIAMETER = 2.0_R8 + MINDIST = 1.0_R8 +END IF +RETURN +END SUBROUTINE RESCALE + +END SUBROUTINE DELAUNAYSPARSES + + +SUBROUTINE DELAUNAYSPARSEP( D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, & + INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EXACT, & + PMODE ) +! This is a parallel implementation of an algorithm for efficiently performing +! interpolation in R^D via the Delaunay triangulation. The algorithm is fully +! described and analyzed in +! +! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. +! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate +! interpolation in arbitrary dimension via the Delaunay triangulation. In +! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, +! USA. Article 12, 8 pages. +! +! +! On input: +! +! D is the dimension of the space for PTS and Q. +! +! N is the number of data points in PTS. +! +! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the +! coordinates of a single data point in R^D. +! +! M is the number of interpolation points in Q. +! +! Q(1:D,1:M) is a real valued matrix with M columns, each containing the +! coordinates of a single interpolation point in R^D. +! +! +! On output: +! +! PTS and Q have been rescaled and shifted. All the data points in PTS +! are now contained in the unit hyperball in R^D, and the points in Q +! have been shifted and scaled accordingly in relation to PTS. +! +! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns +! in PTS) for the D+1 vertices of the Delaunay simplex containing each +! interpolation point in Q. +! +! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each +! point in Q as a convex combination of the D+1 corresponding vertices +! in SIMPS. +! +! IERR(1:M) contains integer valued error flags associated with the +! computation of each of the M interpolation points in Q. The error +! codes are: +! +! 00 : Succesful interpolation. +! 01 : Succesful extrapolation (up to the allowed extrapolation distance). +! 02 : This point was outside the allowed extrapolation distance; the +! corresponding entries in SIMPS and WEIGHTS contain zero values. +! +! 10 : The dimension D must be positive. +! 11 : Too few data points to construct a triangulation (i.e., N < D+1). +! 12 : No interpolation points given (i.e., M < 1). +! 13 : The first dimension of PTS does not agree with the dimension D. +! 14 : The second dimension of PTS does not agree with the number of points N. +! 15 : The first dimension of Q does not agree with the dimension D. +! 16 : The second dimension of Q does not agree with the number of +! interpolation points M. +! 17 : The first dimension of the output array SIMPS does not match the number +! of vertices needed for a D-simplex (D+1). +! 18 : The second dimension of the output array SIMPS does not match the +! number of interpolation points M. +! 19 : The first dimension of the output array WEIGHTS does not match the +! number of vertices for a a D-simplex (D+1). +! 20 : The second dimension of the output array WEIGHTS does not match the +! number of interpolation points M. +! 21 : The size of the error array IERR does not match the number of +! interpolation points M. +! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. +! 23 : The first dimension of INTERP_IN does not match the first +! dimension of INTERP_OUT. +! 24 : The second dimension of INTERP_IN does not match the number of +! data points PTS. +! 25 : The second dimension of INTERP_OUT does not match the number of +! interpolation points M. +! 26 : The budget supplied in IBUDGET does not contain a positive +! integer. +! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. +! 28 : The size of the RNORM output array does not match the number of +! interpolation points M. +! +! 30 : Two or more points in the data set PTS are too close together with +! respect to the working precision (EPS), which would result in a +! numerically degenerate simplex. +! 31 : All the data points in PTS lie in some lower dimensional linear +! manifold (up to the working precision), and no valid triangulation +! exists. +! 40 : An error caused DELAUNAYSPARSEP to terminate before this value could +! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may +! contain garbage values. +! +! 50 : A memory allocation error occurred while allocating the work array +! WORK. +! +! 60 : The budget was exceeded before the algorithm converged on this +! value. If the dimension is high, try increasing IBUDGET. This +! error can also be caused by a working precision EPS that is too +! small for the conditioning of the problem. +! +! 61 : A value that was judged appropriate later caused LAPACK to encounter a +! singularity. Try increasing the value of EPS. +! +! 70 : Allocation error for the extrapolation work arrays. +! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection +! of an extrapolation point onto the convex hull. +! 72 : The SLATEC subroutine DWNNLS has reported a usage error. +! +! The errors 72, 80--83 should never occur, and likely indicate a +! compiler bug or hardware failure. +! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. +! 81 : The LAPACK subroutine DGETRF has reported an illegal value. +! 82 : The LAPACK subroutine DGETRS has reported an illegal value. +! 83 : The LAPACK subroutine DORMQR has reported an illegal value. +! +! 90 : The value of PMODE is not valid. +! +! +! Optional arguments: +! +! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of +! the data points in PTS on input. The first dimension of INTERP_IN is +! inferred to be the dimension of these response vectors, and the +! second dimension must match N. If present, the response values will +! be computed for each interpolation point in Q, and stored in INTERP_OUT, +! which therefore must also be present. If both INTERP_IN and INTERP_OUT +! are omitted, only the containing simplices and convex combination +! weights are returned. +! +! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each +! interpolation point in Q on output. The first dimension of INTERP_OU +! must match the first dimension of INTERP_IN, and the second dimension +! must match M. If present, the response values at each interpolation +! point are computed as a convex combination of the response values +! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing +! that interpolation point. Therefore, if INTERP_OUT is present, then +! INTERP_IN must also be present. If both are omitted, only the +! simplices and convex combination weights are returned. +! +! EPS contains the real working precision for the problem on input. By +! default, EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff +! for the machine. In general, any values that differ by less than EPS +! are judged as equal, and any weights that are greater than -EPS are +! judged as nonnegative. EPS cannot take a value less than the default +! value of \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, +! the default value will be used instead automatically. +! +! EXTRAP contains the real maximum extrapolation distance (relative to the +! diameter of PTS) on input. Interpolation at a point outside the convex +! hull of PTS is done by projecting that point onto the convex hull, and +! then doing normal Delaunay interpolation at that projection. +! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) +! units outside the convex hull of PTS will not be done and an error code +! of 2 will be returned. Note that computing the projection can be +! expensive. Setting EXTRAP=0 will cause all extrapolation points to be +! ignored without ever computing a projection. By default, EXTRAP=0.1 +! (extrapolate by up to 10% of the diameter of PTS). +! +! RNORM(1:M) contains the real unscaled projection (2-norm) distances from +! any projection computations on output. If not present, these distances +! are still computed for each extrapolation point, but are never returned. +! +! IBUDGET on input contains the integer budget for performing flips while +! iterating toward the simplex containing each interpolation point in Q. +! This prevents DELAUNAYSPARSEP from falling into an infinite loop when +! an inappropriate value of EPS is given with respect to the problem +! conditioning. By default, IBUDGET=50000. However, for extremely +! high-dimensional problems and pathological inputs, the default value +! may be insufficient. +! +! CHAIN is a logical input argument that determines whether a new first +! simplex should be constructed for each interpolation point +! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." +! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not +! recommended, unless the size of the triangulation is relatively small +! or the interpolation points are known to be tightly clustered. +! +! EXACT is a logical input argument that determines whether the exact +! diameter should be computed and whether a check for duplicate data +! points should be performed in advance. When EXACT=.FALSE., the +! diameter of PTS is approximated by twice the distance from the +! barycenter of PTS to the farthest point in PTS, and no check is +! done to find the closest pair of points, which could result in hard +! to find bugs later on. When EXACT=.TRUE., the exact diameter is +! computed and an error is returned whenever PTS contains duplicate +! values up to the precision EPS. By default EXACT=.TRUE., but setting +! EXACT=.FALSE. could result in significant speedup when N is large. +! It is strongly recommended that most users leave EXACT=.TRUE., as +! setting EXACT=.FALSE. could result in input errors that are difficult +! to identify. Also, the diameter approximation could be wrong by up to +! a factor of two. +! +! PMODE is an integer specifying the level of parallelism to be exploited. +! If PMODE = 1, then parallelism is exploited at the level of the loop +! over all interpolation points (Level 1 parallelism). +! If PMODE = 2, then parallelism is exploited at the level of the loops +! over data points when constructing/flipping simplices (Level 2 +! parallelism). +! If PMODE = 3, then parallelism is exploited at both levels. Note: this +! implies that the total number of threads active at any time could be up +! to OMP_NUM_THREADS^2. +! By default, PMODE is set to 1 if there is more than 1 interpolation +! point and 2 otherwise. +! +! +! Subroutines and functions directly referenced from BLAS are +! DDOT, DGEMV, DNRM2, DTRSM, +! and from LAPACK are +! DGEQP3, DGETRF, DGETRS, DORMQR. +! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its +! SLATEC dependencies have been slightly edited to comply with the Fortran +! 2008 standard, with all print statements and references to stderr being +! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 +! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS +! Algorithm 777) is used for the real data type. The REAL_PRECISION module, +! DELAUNAYSPARSEP, and DWNNLS and its dependencies comply with the Fortran +! 2008 standard. +! +! Primary Author: Tyler H. Chang +! Last Update: March, 2020 +! +USE REAL_PRECISION, ONLY : R8 +IMPLICIT NONE + +! Input arguments. +INTEGER, INTENT(IN) :: D, N +REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:) ! Rescaled on output. +INTEGER, INTENT(IN) :: M +REAL(KIND=R8), INTENT(INOUT) :: Q(:,:) ! Rescaled on output. +! Output arguments. +INTEGER, INTENT(OUT) :: SIMPS(:,:) +REAL(KIND=R8), INTENT(OUT) :: WEIGHTS(:,:) +INTEGER, INTENT(OUT) :: IERR(:) +! Optional arguments. +REAL(KIND=R8), INTENT(IN), OPTIONAL:: INTERP_IN(:,:) +REAL(KIND=R8), INTENT(OUT), OPTIONAL :: INTERP_OUT(:,:) +REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS, EXTRAP +REAL(KIND=R8), INTENT(OUT), OPTIONAL :: RNORM(:) +INTEGER, INTENT(IN), OPTIONAL :: IBUDGET, PMODE +LOGICAL, INTENT(IN), OPTIONAL :: CHAIN +LOGICAL, INTENT(IN), OPTIONAL :: EXACT + +! Local copies of optional input arguments. +REAL(KIND=R8) :: EPSL, EXTRAPL +INTEGER :: IBUDGETL +LOGICAL :: CHAINL, EXACTL, PLVL1, PLVL2 + +! Local variables. +LOGICAL :: PTINSIMP ! Tells if Q(:,MI) is in SIMPS(:,MI). +INTEGER :: I, J, K ! Loop iteration variables. +INTEGER :: IEXTRAPS ! Extrapolation budget. +INTEGER :: IERR_PRIV ! Private copy of the error flag. +INTEGER :: ITMP, JTMP ! Temporary variables for swapping, looping, etc. +INTEGER :: LWORK ! Size of the work array. +INTEGER :: MI ! Index of current interpolation point. +INTEGER :: VERTEX_PRIV ! Private copy of next vertex to add. +REAL(KIND=R8) :: CURRRAD ! Radius of the current circumsphere. +REAL(KIND=R8) :: MINRAD ! Minimum circumsphere radius observed. +REAL(KIND=R8) :: MINRAD_PRIV ! Private copy of MINRAD. +REAL(KIND=R8) :: PTS_DIAM ! Scaled diameter of data set. +REAL(KIND=R8) :: PTS_SCALE ! Data scaling factor. +REAL(KIND=R8) :: RNORML ! Euclidean norm of the projection residual. +REAL(KIND=R8) :: SIDE1, SIDE2 ! Signs (+/-1) denoting sides of a facet. + +! Local arrays, requiring O(d^2) additional memory. +INTEGER :: IPIV(D) ! Pivot indices. +INTEGER :: SEED(D+1) ! Copy of the SEED simplex. Only used if CHAIN = .TRUE. +REAL(KIND=R8) :: AT(D,D) ! The transpose of A, the linear coefficient matrix. +REAL(KIND=R8) :: B(D) ! The RHS of a linear system. +REAL(KIND=R8) :: CENTER(D) ! The circumcenter of a simplex. +REAL(KIND=R8) :: CENTER_PRIV(D) ! Private copy of CENTER. +REAL(KIND=R8) :: LQ(D,D) ! Holds LU or QR factorization of AT. +REAL(KIND=R8) :: PLANE(D+1) ! The hyperplane containing a facet. +REAL(KIND=R8) :: PRGOPT_DWNNLS(1) ! Options array for DWNNLS. +REAL(KIND=R8) :: PROJ(D) ! The projection of the current iterate. +REAL(KIND=R8) :: TAU(D) ! Householder reflector constants. +REAL(KIND=R8) :: X(D) ! The solution to a linear system. + +! Extrapolation work arrays are only allocated if DWNNLS is called. +INTEGER, ALLOCATABLE :: IWORK_DWNNLS(:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: W_DWNNLS(:,:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: WORK(:) ! Allocated with size LWORK. +REAL(KIND=R8), ALLOCATABLE :: WORK_DWNNLS(:) ! Only for DWNNLS. +REAL(KIND=R8), ALLOCATABLE :: X_DWNNLS(:) ! Only for DWNNLS. + +! External functions and subroutines. +REAL(KIND=R8), EXTERNAL :: DDOT ! Inner product (BLAS). +REAL(KIND=R8), EXTERNAL :: DNRM2 ! Euclidean norm (BLAS). +EXTERNAL :: DGEMV ! General matrix vector multiply (BLAS) +EXTERNAL :: DGEQP3 ! Perform a QR factorization with column pivoting (LAPACK). +EXTERNAL :: DGETRF ! Perform a LU factorization with partial pivoting (LAPACK). +EXTERNAL :: DGETRS ! Use the output of DGETRF to solve a linear system (LAPACK). +EXTERNAL :: DORMQR ! Apply householder reflectors to a matrix (LAPACK). +EXTERNAL :: DTRSM ! Perform a triangular solve (BLAS). +EXTERNAL :: DWNNLS ! Solve an inequality constrained least squares problem + ! (SLATEC). + +! Check for input size and dimension errors. +IF (D < 1) THEN ! The dimension must satisfy D > 0. + IERR(:) = 10; RETURN; END IF +IF (N < D+1) THEN ! Must have at least D+1 data points. + IERR(:) = 11; RETURN; END IF +IF (M < 1) THEN ! Must have at least one interpolation point. + IERR(:) = 12; RETURN; END IF +IF (SIZE(PTS,1) .NE. D) THEN ! Dimension of PTS array should match. + IERR(:) = 13; RETURN; END IF +IF (SIZE(PTS,2) .NE. N) THEN ! Number of data points should match. + IERR(:) = 14; RETURN; END IF +IF (SIZE(Q,1) .NE. D) THEN ! Dimension of Q should match. + IERR(:) = 15; RETURN; END IF +IF (SIZE(Q,2) .NE. M) THEN ! Number of interpolation points should match. + IERR(:) = 16; RETURN; END IF +IF (SIZE(SIMPS,1) .NE. D+1) THEN ! Need space for D+1 vertices per simplex. + IERR(:) = 17; RETURN; END IF +IF (SIZE(SIMPS,2) .NE. M) THEN ! There will be M output simplices. + IERR(:) = 18; RETURN; END IF +IF (SIZE(WEIGHTS,1) .NE. D+1) THEN ! There will be D+1 weights per simplex. + IERR(:) = 19; RETURN; END IF +IF (SIZE(WEIGHTS,2) .NE. M) THEN ! One vector of weights per simplex. + IERR(:) = 20; RETURN; END IF +IF (SIZE(IERR) .NE. M) THEN ! An error flag for each interpolation point. + IERR(:) = 21; RETURN; END IF + +! Check for optional arguments. +IF (PRESENT(INTERP_IN) .NEQV. PRESENT(INTERP_OUT)) THEN + IERR(:) = 22; RETURN; END IF +IF (PRESENT(INTERP_IN)) THEN ! Sizes must agree. + IF (SIZE(INTERP_IN,1) .NE. SIZE(INTERP_OUT,1)) THEN + IERR(:) = 23 ; RETURN; END IF + IF(SIZE(INTERP_IN,2) .NE. N) THEN + IERR(:) = 24; RETURN; END IF + IF (SIZE(INTERP_OUT,2) .NE. M) THEN + IERR(:) = 25; RETURN; END IF + INTERP_OUT(:,:) = 0.0_R8 ! Initialize output to zeros. +END IF +EPSL = SQRT(EPSILON(0.0_R8)) ! Get the machine unit roundoff constant. +IF (PRESENT(EPS)) THEN + IF (EPSL < EPS) THEN ! If the given precision is too small, ignore it. + EPSL = EPS + END IF +END IF +IF (PRESENT(IBUDGET)) THEN + IBUDGETL = IBUDGET ! Use the given budget if present. + IF (IBUDGETL < 1) THEN + IERR(:) = 26; RETURN; END IF +ELSE + IBUDGETL = 50000 ! Default value for budget. +END IF +IF (PRESENT(EXTRAP)) THEN + EXTRAPL = EXTRAP + IF (EXTRAPL < 0) THEN ! Check that the extrapolation distance is legal. + IERR(:) = 27; RETURN; END IF +ELSE + EXTRAPL = 0.1_R8 ! Default extrapolation distance (for normalized points). +END IF +IF (PRESENT(RNORM)) THEN + IF (SIZE(RNORM,1) .NE. M) THEN ! The length of the array must match. + IERR(:) = 28; RETURN; END IF + RNORM(:) = 0.0_R8 ! Initialize output to zeros. +END IF +IF (PRESENT(CHAIN)) THEN + CHAINL = CHAIN ! Turn chaining on, if necessarry. + SEED(:) = 0 ! Initialize SEED in case it is needed. +ELSE + CHAINL = .FALSE. +END IF +IF (PRESENT(EXACT)) THEN + EXACTL = EXACT ! Set error checking and exact diameter computations. +ELSE + EXACTL = .TRUE. +END IF +! Set the PMODE. +PLVL1 = .FALSE. +PLVL2 = .FALSE. +IF (PRESENT(PMODE)) THEN ! Check PMODE for legal values. + IF (PMODE .EQ. 1) THEN + PLVL1 = .TRUE. + ELSE IF (PMODE .EQ. 2) THEN + PLVL2 = .TRUE. + ELSE IF (PMODE .EQ. 3) THEN + PLVL1 = .TRUE.; PLVL2 = .TRUE. + ELSE + IERR(:) = 90; RETURN + END IF +ELSE ! The default setting for PMODE is level 1 parallelism if M > 1. + IF (M > 1) THEN + PLVL1 = .TRUE. + ELSE + PLVL2 = .TRUE. + END IF +END IF + +! Scale and center the data points and interpolation points. +CALL RESCALE(MINRAD, PTS_DIAM, PTS_SCALE) +IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. + IERR(:) = 30; RETURN; END IF + +! Query DGEQP3 for optimal work array size (LWORK). +LWORK = -1 +CALL DGEQP3(D,D,LQ,D,IPIV,TAU,B,LWORK,IERR(1)) +LWORK = INT(B(1)) ! Compute the optimal work array size. +ALLOCATE(WORK(LWORK), STAT=I) ! Allocate WORK to size LWORK. +IF (I .NE. 0) THEN ! Check for memory allocation errors. + IERR(:) = 50; RETURN; END IF + +! Initialize PRGOPT_DWNNLS in case of extrapolation. +PRGOPT_DWNNLS(1) = 1.0_R8 + +! Initialize all error codes to "TBD" values. +IERR(:) = 40 + +! Begin level 1 parallel region (over all interpolation points in Q). +!$OMP PARALLEL & +! +! The FIRSTPRIVATE list specifies initialized variables, of which each +! thread has a private copy. +!$OMP& FIRSTPRIVATE(SEED), & +! +! The PRIVATE list specifies uninitialized variables, of which each +! thread has a private copy. +!$OMP& PRIVATE(I, J, K, IEXTRAPS, ITMP, JTMP, CURRRAD, MI, MINRAD, & +!$OMP& RNORML, SIDE1, SIDE2, IERR_PRIV, VERTEX_PRIV, MINRAD_PRIV, & +!$OMP& PTINSIMP, IPIV, AT, B, CENTER, CENTER_PRIV, LQ, PLANE, & +!$OMP& PROJ, TAU, WORK, X, IWORK_DWNNLS, W_DWNNLS, WORK_DWNNLS, & +!$OMP& X_DWNNLS), & +! +! Any variables not explicitly listed above receive the SHARED scope +! by default and are visible across all threads. +!$OMP& DEFAULT(SHARED), & +! +!$OMP& IF(PLVL1) +!$OMP DO SCHEDULE(DYNAMIC) +OUTER : DO MI = 1, M + !$OMP CRITICAL(CHECK_IERR) + ! Check if this interpolation point was already found. + IF (IERR(MI) .EQ. 40) THEN + IERR(MI) = 0 + IERR_PRIV = 0 + ELSE + IERR_PRIV = -1 + END IF + !$OMP END CRITICAL(CHECK_IERR) + IF(IERR_PRIV .EQ. -1) CYCLE OUTER + + ! Initialize the projection and reset the residual. + PROJ(:) = Q(:,MI) + RNORML = 0.0_R8 + + ! Check if extrapolation is enabled. + IF (EXTRAPL < EPSL) THEN + IEXTRAPS = -1 ! If not, set the extrapolation budget negative. + ELSE + IEXTRAPS = 1 ! Allow for exactly one projection for this point. + END IF + + ! If there is no useable seed or if chaining is turned off, then make a new + ! simplex. + IF( (.NOT. CHAINL) .OR. SEED(1) .EQ. 0) THEN +! CALL MAKEFIRSTSIMP(); IF(IERR_PRIV .NE. 0) CYCLE OUTER + + +!****************************************************************************** +! Due to OpenMP's handling of variable scope, the parallel implementation of +! the subroutine MAKEFIRSTSIMP() has been in-lined here. +! +! SUBROUTINE MAKEFIRSTSIMP() +! +! Iteratively construct the first simplex by choosing points that +! minimize the radius of the smallest circumball. Let P_1, P_2, ..., P_K +! denote the current list of vertices for the simplex. Let P* denote the +! candidate vertex to be added to the simplex. Let CENTER denote the +! circumcenter of the simplex. Then +! +! X = CENTER - P_1 +! +! is given by the minimum norm solution to the underdetermined linear system +! +! A X = B, where +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_K - P_1, P* - P_1 ] and +! B = [ /2, /2, ..., /2 ]^T. +! +! Then the radius of the smallest circumsphere is CURRRAD = \| X \|, +! and the next vertex is given by P_{K+1} = argmin_{P*} CURRRAD, where P* +! ranges over points in PTS that are not already a vertex of the simplex. +! +! On output, this subroutine fully populates the matrix A^T and vector B, +! and fills SIMPS(:,MI) with the indices of a valid Delaunay simplex. + +! Initialize simplex and shared variables. +SIMPS(:,MI) = 0 +MINRAD_PRIV = HUGE(0.0_R8) +MINRAD = HUGE(0.0_R8) + +! Below is a Level 2 parallel region over N points in PTS to find the +! first and second vertices SIMPS(1,MI) and SIMPS(2,MI). +!$OMP PARALLEL & +! +! The FIRSTPRIVATE list specifies initialized variables, of which each +! thread has a private copy. +!$OMP& FIRSTPRIVATE(MINRAD_PRIV), & +! +! The PRIVATE list specifies uninitialized variables, of which each +! thread has a private copy. +!$OMP& PRIVATE(I, CURRRAD, VERTEX_PRIV), & +! +! Any variables not explicitly listed above receive the SHARED scope +! by default and are visible across all threads. +!$OMP& DEFAULT(SHARED), & +! +!$OMP& IF(PLVL2) +! Find the first point, i.e., the closest point to Q(:,MI). +!$OMP DO SCHEDULE(STATIC) +DO I = 1, N + ! Check the distance to Q(:,MI) + CURRRAD = DNRM2(D, PTS(:,I) - PROJ(:), 1) + IF (CURRRAD < MINRAD_PRIV) THEN + MINRAD_PRIV = CURRRAD; VERTEX_PRIV = I; + END IF +END DO +!$OMP END DO +!$OMP CRITICAL(REDUC_1) +IF (MINRAD_PRIV < MINRAD) THEN + MINRAD = MINRAD_PRIV; SIMPS(1,MI) = VERTEX_PRIV; +END IF +!$OMP END CRITICAL(REDUC_1) +! Find the second point, i.e., the closest point to PTS(:,SIMPS(1,MI)). +MINRAD_PRIV = HUGE(0.0_R8) +!$OMP BARRIER +!$OMP SINGLE +MINRAD = HUGE(0.0_R8) +!$OMP END SINGLE +!$OMP DO SCHEDULE(STATIC) +DO I = 1, N + ! Skip repeated vertices. + IF (I .EQ. SIMPS(1,MI)) CYCLE + ! Check the diameter of the resulting circumsphere. + CURRRAD = DNRM2(D, PTS(:,I)-PTS(:,SIMPS(1,MI)), 1) + IF (CURRRAD < MINRAD_PRIV) THEN + MINRAD_PRIV = CURRRAD; VERTEX_PRIV = I + END IF +END DO +!$OMP END DO +!$OMP CRITICAL(REDUC_2) +IF (MINRAD_PRIV < MINRAD) THEN + MINRAD = MINRAD_PRIV; SIMPS(2,MI) = VERTEX_PRIV +END IF +!$OMP END CRITICAL(REDUC_2) +!$OMP END PARALLEL +! This is the end of the Level 2 parallel block. +IF (MINRAD < EPSL) THEN ! Check for degeneracies in points spacing. + IERR(MI) = 30; CYCLE OUTER; END IF + +! Set up the first row of the system A X = B. +AT(:,1) = PTS(:,SIMPS(2,MI)) - PTS(:,SIMPS(1,MI)) +B(1) = DDOT(D, AT(:,1), 1, AT(:,1), 1) / 2.0_R8 + +! Loop to collect the remaining D-1 vertices for the first simplex. +DO I = 2, D + ! Compute A^T P = Q R for the current matrix A^T. + LQ(:,1:I-1) = AT(:,1:I-1) + CALL DGEQP3(D, I-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 80 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Set the RHS to P^T B. + FORALL (ITMP = 1:I-1) X(ITMP) = B(IPIV(ITMP)) + ! Solve R^T Q^T X = P^T B for Q^T X, and save for later. + CALL DTRSM('L', 'U', 'T', 'N', I-1, 1, 1.0_R8, LQ, D, X, D) + ! Make a copy for computing the current center. + CENTER(1:I-1) = X(1:I-1) + CENTER(I:D) = 0.0_R8 + ! Apply Q from the left. + CALL DORMQR('L', 'N', D, 1, I-1, LQ, D, TAU, CENTER, D, WORK, & + LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 83 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + CENTER = CENTER + PTS(:,SIMPS(1,MI)) + ! Re-initialize the radius for each iteration. + MINRAD = HUGE(0.0_R8) + MINRAD_PRIV = HUGE(0.0_R8) + VERTEX_PRIV = 0 + + ! This is another Level 2 parallel block over N points in PTS. + !$OMP PARALLEL & + ! + ! The FIRSTPRIVATE list specifies initialized variables, of which each + ! thread has a private copy. + !$OMP& FIRSTPRIVATE(LQ, MINRAD_PRIV, VERTEX_PRIV, X), & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(J, CURRRAD, WORK), & + ! + ! The REDUCTION clause specifies a PRIVATE variable that will retain + ! some value (i.e., max, min, sum, etc.) upon output. + !$OMP& REDUCTION(MAX:IERR_PRIV), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& IF(PLVL2) + + ! Initialize the error flag. + IERR_PRIV = 0 + !$OMP DO SCHEDULE(STATIC) + DO J = 1, N + IF (IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. + ! Check that this point is not already in the simplex. + IF (ANY(SIMPS(:,MI) .EQ. J)) CYCLE + ! If PTS(:,J) is more than twice MINRAD_PRIV from CENTER, do a quick skip. + IF (DNRM2(D, CENTER - PTS(:,J), 1) > 2.0_R8 * MINRAD_PRIV) CYCLE + ! Perform a rank-1 update to the current QR factorization of A^T by + ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the + ! final column of R. + LQ(:,I) = PTS(:,J) - PTS(:,SIMPS(1,MI)) + CALL DORMQR('L', 'T', D, 1, I-1, LQ(:,1:I-1), D, TAU, LQ(:,I), D, & + WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + IERR_PRIV = 83; CYCLE + END IF + ! Implicitly apply the next Householder reflector. + LQ(I,I) = DNRM2(D+1-I, LQ(I:D,I), 1) + IF (LQ(I,I) < EPSL) THEN ! A is rank-deficient. + CYCLE ! If rank-deficient, skip this point. + END IF + ! Update the current radius by \| Q^T X \| = \| X \|. + WORK(1:I-1) = (LQ(1:I-1,I) / 2.0_R8) - X(1:I-1) + WORK(I) = LQ(I,I) / 2.0_R8 + X(I) = DDOT(I, LQ(1:I,I), 1, WORK(1:I), 1) / LQ(I,I) + CURRRAD = DNRM2(I, X(1:I), 1) + ! Compare the last component of Q^T X to the current minimum. + IF (CURRRAD < MINRAD_PRIV) THEN + MINRAD_PRIV = CURRRAD; VERTEX_PRIV = J + END IF + END DO + !$OMP END DO + !$OMP CRITICAL(REDUC_3) + IF (MINRAD_PRIV < MINRAD) THEN + MINRAD = MINRAD_PRIV; SIMPS(I+1,MI) = VERTEX_PRIV + END IF + !$OMP END CRITICAL(REDUC_3) + !$OMP END PARALLEL + ! End of Level 2 parallel block. + + ! Check the final error flag. + IF (IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = IERR_PRIV + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Check that a point was found. If not, then all the points must lie in a + ! lower dimensional linear manifold (error case). + IF (SIMPS(I+1,MI) .EQ. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 31 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! If all operations were successful, add the best P* to the linear system. + AT(:,I) = PTS(:,SIMPS(I+1,MI)) - PTS(:,SIMPS(1,MI)) + B(I) = DDOT(D, AT(:,I), 1, AT(:,I), 1) / 2.0_R8 +END DO +! RETURN +! END SUBROUTINE MAKEFIRSTSIMP +! This marks the end of the in-lined MAKEFIRSTSIMP() subroutine call. +!****************************************************************************** + + + ! Otherwise, use the seed. + ELSE + ! Copy the seed to the current simplex. + SIMPS(:,MI) = SEED(:) + ! Rebuild the linear system. + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + + ! Inner loop searching for a simplex containing the point Q(:,MI). + INNER : DO K = 1, IBUDGETL + + ! If chaining is on, save each good simplex as the next seed. + IF (CHAINL) SEED(:) = SIMPS(:,MI) + + +!****************************************************************************** +! Due to OpenMP's handling of variable scope, the parallel implementation of +! the subroutine PTINSIMP() has been in-lined here. +! +! FUNCTION PTINSIMP() RESULT(TF) +! Determine if any interpolation points are in the current simplex, whose +! vertices (P_1, P_2, ..., P_{D+1}) are indexed by SIMPS(:,MI). These +! vertices determine a positive cone with generators V_I = P_{I+1} - P_1, +! I = 1, ..., D. For each interpolation point Q* in Q, Q* - P_1 can be +! expressed as a unique linear combination of the V_I. If all these linear +! weights are nonnegative and sum to less than or equal to 1.0, then Q* is +! in the simplex with vertices {P_I}_{I=1}^{D+1}. +! +! If any interpolation points in Q are contained in the simplex whose +! vertices are indexed by SIMPS(:,MI), then those points are marked as solved +! and the values of SIMPS and WEIGHTS are updated appropriately. On output, +! WEIGHTS(:,MI) contains the affine weights for producing Q(:,MI) as an +! affine combination of the points in PTS indexed by SIMPS(:,MI). If these +! weights are nonnegative, then PTINSIMP() returns TRUE. + +! Initialize the return value and local variables. +PTINSIMP = .FALSE. + +! Compute the LU factorization of the matrix A^T, whose columns are +! P_{I+1} - P_1. +LQ = AT +CALL DGETRF(D, D, LQ, D, IPIV, IERR_PRIV) +IF (IERR_PRIV < 0) THEN ! LAPACK illegal input. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 81 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER +ELSE IF (IERR_PRIV > 0) THEN ! Rank-deficiency detected. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 61 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER +END IF +! Solve A^T w = WORK to get the affine weights for Q(:,MI) or its projection. +WORK(1:D) = PROJ(:) - PTS(:,SIMPS(1,MI)) +CALL DGETRS('N', D, 1, LQ, D, IPIV, WORK(1:D), D, IERR_PRIV) +IF (IERR_PRIV < 0) THEN ! LAPACK illegal input. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 82 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER +END IF +WEIGHTS(2:D+1,MI) = WORK(1:D) +WEIGHTS(1,MI) = 1.0_R8 - SUM(WEIGHTS(2:D+1,MI)) +! Check if the weights for Q(:,MI) are nonnegative. +IF (ALL(WEIGHTS(:,MI) .GE. -EPSL)) PTINSIMP = .TRUE. + +! If Level 1 parallelism is active, do not parallelize this loop. +IF (PLVL1) THEN + ! Loop over all remaining unsolved interoplation points. Uses PLANE(:) + ! as a work array. + DO I = MI+1, M + ! Check that no solution has already been found. + !$OMP CRITICAL(CHECK_IERR) + ITMP = IERR(I) + !$OMP END CRITICAL(CHECK_IERR) + IF (ITMP .NE. 40) CYCLE + ! Solve A^T w = PLANE to get the affine weights for Q(:,I). + PLANE(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) + CALL DGETRS('N', D, 1, LQ, D, IPIV, PLANE(2:D+1), D, ITMP) + IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. + ! Check if the weights define a convex combination. + PLANE(1) = 1.0_R8 - SUM(PLANE(2:D+1)) + IF (ALL(PLANE(1:D+1) .GE. -EPSL)) THEN + !$OMP CRITICAL(CHECK_IERR) + IF(IERR(I) .EQ. 40) THEN + ! Copy the simplex indices and weights then flag as complete. + SIMPS(:,I) = SIMPS(:,MI) + WEIGHTS(:,I) = PLANE(1:D+1) + IERR(I) = 0 + END IF + !$OMP END CRITICAL(CHECK_IERR) + END IF + END DO +! If Level 1 parallelism is not active, there will be no conflicts for +! parallelizing this loop. +ELSE + ! Level 2 parallel block over all remaining unsolved interoplation + ! points. Uses PLANE(:) as a work array. + !$OMP PARALLEL DO & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(I, PLANE, ITMP), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& SCHEDULE(STATIC), & + !$OMP& IF(PLVL2) + DO I = MI+1, M + ! Check that no solution has already been found. + IF (IERR(I) .NE. 40) CYCLE + ! Solve A^T w = PLANE to get the affine weights for Q(:,I). + PLANE(2:D+1) = Q(:,I) - PTS(:,SIMPS(1,MI)) + CALL DGETRS('N', D, 1, LQ, D, IPIV, PLANE(2:D+1), D, ITMP) + IF (ITMP < 0) CYCLE ! Illegal input error that should never occurr. + ! Check if the weights define a convex combination. + PLANE(1) = 1.0_R8 - SUM(PLANE(2:D+1)) + IF (ALL(PLANE(1:D+1) .GE. -EPSL)) THEN + ! Copy the simplex indices and weights then flag as complete. + SIMPS(:,I) = SIMPS(:,MI) + WEIGHTS(:,I) = PLANE(1:D+1) + IERR(I) = 0 + END IF + END DO + !$OMP END PARALLEL DO +END IF +! End of Level 2 parallel block. +! RETURN +! END FUNCTION PTINSIMP +! This marks the end of the in-lined PTINSIMP() subroutine call. +!****************************************************************************** + + + ! Check if the current simplex contains Q(:,MI). + IF (PTINSIMP) EXIT INNER + + ! Swap out the least weighted vertex, but save its value in case it + ! needs to be restored later. + JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) + ITMP = SIMPS(JTMP,MI) + SIMPS(JTMP,MI) = SIMPS(D+1,MI) + + ! If the least weighted vertex (index JTMP) is not the first vertex, + ! then just drop row (JTMP-1) from the linear system (corresponding + ! to column (JTMP-1) of A^T). + IF(JTMP .NE. 1) THEN + AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) + ! However, if JTMP = 1, then both A^T and B must be reconstructed. + ELSE + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + + ! Compute the next simplex (do one flip). +! CALL MAKESIMPLEX(); IF (IERR_PRIV .NE. 0) CYCLE OUTER + + +!****************************************************************************** +! Due to OpenMP's handling of variable scope, the parallel implementation of +! the subroutine MAKESIMPLEX() has been in-lined here. +! +! SUBROUTINE MAKESIMPLEX() +! Given a Delaunay facet F whose containing hyperplane does not contain +! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' +! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F +! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the +! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly +! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing +! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices +! P_1, P_2, ..., P_D, P*. Then +! +! X = CENTER - P_1 +! +! is given by the solution to the nonsingular linear system +! +! A X = B where +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and +! B = [ /2, /2, ..., /2 ]^T. +! +! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the +! candidate P* that satisfies both of the following: +! +! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) +! must be on the same side of PLANE. +! +! 2) The circumball about CENTER must not contain any points in PTS in its +! interior (Delaunay property). +! +! The above are necessary and sufficient conditions for flipping the +! Delaunay simplex, given that F is indeed a Delaunay facet. +! +! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices +! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex +! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and +! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were +! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an +! extrapolation point (not a convex combination of points in PTS). + +! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed +! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. +! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal +! vector is any nonzero vector in ker A, where the matrix +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. +! +! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR +! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. +! Then the last column of Q is orthogonal to the range of A^T, and in ker A. +IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. + ! Compute the QR factorization. + IPIV=0 + LQ = AT + CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 80 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! The nullspace is given by the last column of Q. + PLANE(1:D-1) = 0.0_R8 + PLANE(D) = 1.0_R8 + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & + LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 83 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Calculate the constant \alpha defining the plane. + PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) + ! Compute the sign for the side of PLANE containing Q(:,MI). + SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) + SIDE1 = SIGN(1.0_R8,SIDE1) + + ! Set the RHS to P^T B. + FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) + ! Solve R^T Q^T X = P^T B for Q^T X. + CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) + + ! Initialize the center, radius, simplex, and OpenMP variabls. + SIMPS(D+1,MI) = 0 + CENTER(:) = 0.0_R8 + CENTER_PRIV(:) = 0.0_R8 + MINRAD = HUGE(0.0_R8) + MINRAD_PRIV = HUGE(0.0_R8) + VERTEX_PRIV = 0 + + ! Begin Level 2 parallel loop over N points in PTS. + !$OMP PARALLEL & + ! + ! The FIRSTPRIVATE list specifies initialized variables, of which each + ! thread has a private copy. + !$OMP& FIRSTPRIVATE(CENTER_PRIV, LQ, MINRAD_PRIV, VERTEX_PRIV), & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(I, SIDE2, WORK), & + ! + ! The REDUCTION clause specifies a PRIVATE variable that will retain + ! some value (i.e., max, min, sum, etc.) upon output. + !$OMP& REDUCTION(MAX:IERR_PRIV), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& IF(PLVL2) + + ! Initialize the error flag. + IERR_PRIV = 0 + !$OMP DO SCHEDULE(STATIC) + DO I = 1, N + IF(IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. + ! Check that P* is inside the current ball. + IF (DNRM2(D, PTS(:,I) - CENTER_PRIV(:), 1) > MINRAD_PRIV) CYCLE + ! Check that P* is on the appropriate halfspace. + SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) + IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE + ! Perform a rank-1 update to the current QR factorization of A^T by + ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the + ! final column of R. + LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) + CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & + LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + IERR_PRIV = 83; CYCLE + END IF + ! Update the last element of Q^T X. + WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) + WORK(D) = LQ(D,D) / 2.0_R8 + CENTER_PRIV(1:D-1) = X(1:D-1) + CENTER_PRIV(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) + ! Get the center by applying Q to the solution. + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER_PRIV, D, & + WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + IERR_PRIV = 83; CYCLE + END IF + ! Update the new radius, center, and simplex. + MINRAD_PRIV = DNRM2(D, CENTER_PRIV, 1) + CENTER_PRIV(:) = CENTER_PRIV(:) + PTS(:,SIMPS(1,MI)) + VERTEX_PRIV = I + END DO + !$OMP END DO + !$OMP CRITICAL(REDUC_4) + ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. + IF (VERTEX_PRIV .NE. 0) THEN + IF (DNRM2(D, PTS(:,VERTEX_PRIV) - CENTER(:), 1) < MINRAD) THEN + MINRAD = MINRAD_PRIV + CENTER(:) = CENTER_PRIV(:) + SIMPS(D+1,MI) = VERTEX_PRIV + END IF + END IF + !$OMP END CRITICAL(REDUC_4) + !$OMP END PARALLEL + ! End level 2 parallel region. + + ! Check for error flags. + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = IERR_PRIV + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Check for extrapolation condition. + IF(SIMPS(D+1,MI) .NE. 0) THEN + ! Add new point to the linear system. + AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + END IF +ELSE ! Special case where D=1. + PLANE(1) = 1.0_R8 + PLANE(2) = PTS(1,SIMPS(1,MI)) + SIDE1 = SIGN(1.0_R8, PROJ(1) - PLANE(2)) + ! Initialize the radius, simplex, and OpenMP variabls. + SIMPS(2,MI) = 0 + MINRAD = HUGE(0.0_R8) + MINRAD_PRIV = HUGE(0.0_R8) + VERTEX_PRIV = 0 + ! Begin Level 2 parallel loop over N points in PTS. + !$OMP PARALLEL & + ! + ! The FIRSTPRIVATE list specifies initialized variables, of which each + ! thread has a private copy. + !$OMP& FIRSTPRIVATE(MINRAD_PRIV, VERTEX_PRIV), & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(I, SIDE2), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& IF(PLVL2) + + !$OMP DO SCHEDULE(STATIC) + DO I = 1, N + ! Check that P* is on the appropriate halfspace. + SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 + IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE + ! Check that P* is closer than the current solution. + IF (SIDE2 > MINRAD) CYCLE + ! Update the minimum distance and save the index I. + MINRAD_PRIV = SIDE2 + VERTEX_PRIV = I + END DO + !$OMP END DO + !$OMP CRITICAL(REDUC_4) + ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. + IF (VERTEX_PRIV .NE. 0) THEN + IF (MINRAD_PRIV < MINRAD) THEN + MINRAD = MINRAD_PRIV + SIMPS(2,MI) = VERTEX_PRIV + END IF + END IF + !$OMP END CRITICAL(REDUC_4) + !$OMP END PARALLEL + ! Check for extrapolation condition. + IF(SIMPS(2,MI) .NE. 0) THEN + ! Add new point to the linear system. + AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) + B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 + END IF +END IF +! RETURN +! END SUBROUTINE MAKESIMPLEX +! End of in-lined code for MAKESIMPLEX(). +!****************************************************************************** + + + ! If no vertex was found, then this is an extrapolation point. + IF (SIMPS(D+1,MI) .EQ. 0) THEN + ! If extrapolation is not allowed (EXTRAP=0), do not proceed. + IF (IEXTRAPS < 0) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! Set the error flag and skip this point. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 2 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + + ! If extrapolation is allowed (EXTRAP>0), check the budget. + ELSE IF (IEXTRAPS .EQ. 0) THEN + ! A second projection has been attempted. This code is rarely + ! called, except in extreme cases involving nearly singular + ! simplices near the convex hull of P. + + ! Swap the weights to match the simplex indices, and zero the + ! most negative weight. + !$OMP CRITICAL(CHECK_IERR) + WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) + WEIGHTS(D+1,MI) = 0.0_R8 + !$OMP END CRITICAL(CHECK_IERR) + ! Loop through all the remaining facets from which Q(:,MI) is + ! visible, and attempt to flip across each one. + DO WHILE (SIMPS(D+1,MI) .EQ. 0) + ! Restore the previous simplex and linear system. + SIMPS(D+1,MI) = ITMP + AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + ! Find the next most negative weight. + JTMP = MINLOC(WEIGHTS(1:D+1,MI), DIM=1) + ! Check if WEIGHTS(JTMP,MI) .GE. 0. + IF (WEIGHTS(JTMP,MI) .GE. -EPSL) THEN + ! There is no other direction to flip, so Q(:,MI) must be + ! within EPSL of the current simplex. + ! Project Q(:,MI) onto the current simplex. + + ! Since at least one projection has already been done, + ! the work arrays have already been allocated. + PRGOPT_DWNNLS(1) = 1.0_R8 + IWORK_DWNNLS(1) = 6*D + 6 + IWORK_DWNNLS(2) = 2*D + 2 + ! Set equality constraint. + W_DWNNLS(1,1:D+2) = 1.0_R8 + ! Populate LS coefficient matrix and RHS. + FORALL (I=1:D+1) W_DWNNLS(2:D+1,I) = PTS(:,SIMPS(I,MI)) + W_DWNNLS(2:D+1,D+2) = PROJ(:) + ! Project onto the current simplex. + CALL DWNNLS(W_DWNNLS, D+1, 1, D, D+1, 0, PRGOPT_DWNNLS, & + WEIGHTS(:,MI), WORK(1), IERR_PRIV, IWORK_DWNNLS, & + WORK_DWNNLS) + IF (IERR_PRIV .EQ. 1) THEN ! Failure to converge. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 71 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + ELSE IF (IERR_PRIV .EQ. 2) THEN ! Illegal input detected. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 72 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! A solution has been found; return it. + EXIT INNER + END IF + ! Otherwise, swap the vertices. + ITMP = SIMPS(JTMP,MI) + SIMPS(JTMP,MI) = SIMPS(D+1,MI) + ! Swap the weights to match, and zero the most negative weight. + !$OMP CRITICAL(CHECK_IERR) + WEIGHTS(JTMP,MI) = WEIGHTS(D+1,MI) + WEIGHTS(D+1,MI) = 0.0_R8 + !$OMP END CRITICAL(CHECK_IERR) + ! If the least weighted vertex (index JTMP) is not the first vertex, + ! then just drop row (JTMP-1) from the linear system + ! (corresponding to the JTMP-1st column of A^T). + IF (JTMP .NE. 1) THEN + AT(:,JTMP-1) = AT(:,D); B(JTMP-1) = B(D) + ! However, if JTMP=1, then both A^T and B must be reconstructed. + ELSE + DO J=1,D + AT(:,J) = PTS(:,SIMPS(J+1,MI)) - PTS(:,SIMPS(1,MI)) + B(J) = DDOT(D, AT(:,J), 1, AT(:,J), 1) / 2.0_R8 + END DO + END IF + ! Compute another simplex (try to flip again). +! CALL MAKESIMPLEX(); IF (IERR(MI) .NE. 0) CYCLE OUTER + + +!****************************************************************************** +! Due to OpenMP's handling of variable scope, the parallel implementation of +! the subroutine MAKESIMPLEX() has been in-lined here. +! +! SUBROUTINE MAKESIMPLEX() +! Given a Delaunay facet F whose containing hyperplane does not contain +! Q(:,MI), complete the simplex by adding a point from PTS on the same `side' +! of F as Q(:,MI). Assume SIMPS(1:D,MI) contains the vertex indices of F +! (corresponding to data points P_1, P_2, ..., P_D in PTS), and assume the +! matrix A(1:D-1,:)^T and vector B(1:D-1) are filled appropriately (similarly +! as in MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing +! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices +! P_1, P_2, ..., P_D, P*. Then +! +! X = CENTER - P_1 +! +! is given by the solution to the nonsingular linear system +! +! A X = B where +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and +! B = [ /2, /2, ..., /2 ]^T. +! +! Then CENTER = X + P_1 and RADIUS = \| X \|. P_{D+1} will be given by the +! candidate P* that satisfies both of the following: +! +! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and Q(:,MI) +! must be on the same side of PLANE. +! +! 2) The circumball about CENTER must not contain any points in PTS in its +! interior (Delaunay property). +! +! The above are necessary and sufficient conditions for flipping the +! Delaunay simplex, given that F is indeed a Delaunay facet. +! +! On input, SIMPS(1:D,MI) should contain the vertex indices (column indices +! from PTS) of the facet F. Upon output, SIMPS(:,MI) will contain the vertex +! indices of a Delaunay simplex closer to Q(:,MI). Also, the matrix A^T and +! vector B will be updated accordingly. If SIMPS(D+1,MI)=0, then there were +! no points in PTS on the appropriate side of F, meaning that Q(:,MI) is an +! extrapolation point (not a convex combination of points in PTS). + +! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed +! in SIMPS(:,MI). The plane is determined by its normal vector c and \alpha. +! Let P_1, P_2, ..., P_D be the vertices indexed in SIMPS(1:D,MI). A normal +! vector is any nonzero vector in ker A, where the matrix +! +! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ]. +! +! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR +! factorization of A^T: A^T P = QR, where P permutes the columns of A^T. +! Then the last column of Q is orthogonal to the range of A^T, and in ker A. +IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial. + ! Compute the QR factorization. + IPIV=0 + LQ = AT + CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 80 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! The nullspace is given by the last column of Q. + PLANE(1:D-1) = 0.0_R8 + PLANE(D) = 1.0_R8 + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, & + LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 83 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Calculate the constant \alpha defining the plane. + PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMPS(1,MI)),1) + ! Compute the sign for the side of PLANE containing Q(:,MI). + SIDE1 = DDOT(D,PLANE(1:D),1,PROJ(:),1) - PLANE(D+1) + SIDE1 = SIGN(1.0_R8,SIDE1) + ! Set the RHS to P^T B. + FORALL (ITMP = 1:D-1) X(ITMP) = B(IPIV(ITMP)) + ! Solve R^T Q^T X = P^T B for Q^T X. + CALL DTRSM('L', 'U', 'T', 'N', D-1, 1, 1.0_R8, LQ, D, X, D) + ! Initialize the center, radius, simplex, and OpenMP variabls. + SIMPS(D+1,MI) = 0 + CENTER(:) = 0.0_R8 + CENTER_PRIV(:) = 0.0_R8 + MINRAD = HUGE(0.0_R8) + MINRAD_PRIV = HUGE(0.0_R8) + VERTEX_PRIV = 0 + + ! Begin Level 2 parallel loop over N points in PTS. + !$OMP PARALLEL & + ! + ! The FIRSTPRIVATE list specifies initialized variables, of which each + ! thread has a private copy. + !$OMP& FIRSTPRIVATE(CENTER_PRIV, LQ, MINRAD_PRIV, VERTEX_PRIV), & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(I, SIDE2, WORK), & + ! + ! The REDUCTION clause specifies a PRIVATE variable that will retain + ! some value (i.e., max, min, sum, etc.) upon output. + !$OMP& REDUCTION(MAX:IERR_PRIV), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& IF(PLVL2) + + ! Initialize the error flag. + IERR_PRIV = 0 + !$OMP DO SCHEDULE(STATIC) + DO I = 1, N + IF(IERR_PRIV .NE. 0) CYCLE ! If an error occurs, skip to the end. + ! Check that P* is inside the current ball. + IF (DNRM2(D, PTS(:,I) - CENTER_PRIV(:), 1) > MINRAD_PRIV) CYCLE + ! Check that P* is on the appropriate halfspace. + SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1) + IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMPS(:,MI) .EQ. I)) CYCLE + ! Perform a rank-1 update to the current QR factorization of A^T by + ! rotating PTS(:,I) - PTS(:,SIMPS(1,MI) by Q^T and storing in the + ! final column of R. + LQ(:,D) = PTS(:,I) - PTS(:,SIMPS(1,MI)) + CALL DORMQR('L', 'T', D, 1, D-1, LQ(:,1:D-1), D, TAU, LQ(:,D), D, WORK, & + LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + IERR_PRIV = 83; CYCLE + END IF + ! Update the last element of Q^T X. + WORK(1:D-1) = (LQ(1:D-1,D) / 2.0_R8) - X(1:D-1) + WORK(D) = LQ(D,D) / 2.0_R8 + CENTER_PRIV(1:D-1) = X(1:D-1) + CENTER_PRIV(D) = DDOT(D, LQ(:,D), 1, WORK(1:D), 1) / LQ(D,D) + ! Get the center by applying Q to the solution. + CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, CENTER_PRIV, D, & + WORK, LWORK, IERR_PRIV) + IF(IERR_PRIV < 0) THEN ! LAPACK illegal input error. + IERR_PRIV = 83; CYCLE + END IF + ! Update the new radius, center, and simplex. + MINRAD_PRIV = DNRM2(D, CENTER_PRIV, 1) + CENTER_PRIV(:) = CENTER_PRIV(:) + PTS(:,SIMPS(1,MI)) + VERTEX_PRIV = I + END DO + !$OMP END DO + !$OMP CRITICAL(REDUC_4) + ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. + IF (VERTEX_PRIV .NE. 0) THEN + IF (DNRM2(D, PTS(:,VERTEX_PRIV) - CENTER(:), 1) < MINRAD) THEN + MINRAD = MINRAD_PRIV + CENTER(:) = CENTER_PRIV(:) + SIMPS(D+1,MI) = VERTEX_PRIV + END IF + END IF + !$OMP END CRITICAL(REDUC_4) + !$OMP END PARALLEL + ! End level 2 parallel region. + + ! Check for error flags. + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = IERR_PRIV + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + ! Check for extrapolation condition. + IF(SIMPS(D+1,MI) .NE. 0) THEN + ! Add new point to the linear system. + AT(:,D) = PTS(:,SIMPS(D+1,MI)) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + END IF +ELSE ! Special case where D=1. + PLANE(1) = 1.0_R8 + PLANE(2) = PTS(1,SIMPS(1,MI)) + SIDE1 = SIGN(1.0_R8, PROJ(1) - PLANE(2)) + ! Initialize the radius, simplex, and OpenMP variabls. + SIMPS(2,MI) = 0 + MINRAD = HUGE(0.0_R8) + MINRAD_PRIV = HUGE(0.0_R8) + VERTEX_PRIV = 0 + ! Begin Level 2 parallel loop over N points in PTS. + !$OMP PARALLEL & + ! + ! The FIRSTPRIVATE list specifies initialized variables, of which each + ! thread has a private copy. + !$OMP& FIRSTPRIVATE(MINRAD_PRIV, VERTEX_PRIV), & + ! + ! The PRIVATE list specifies uninitialized variables, of which each + ! thread has a private copy. + !$OMP& PRIVATE(I, SIDE2), & + ! + ! Any variables not explicitly listed above receive the SHARED scope + ! by default and are visible across all threads. + !$OMP& DEFAULT(SHARED), & + ! + !$OMP& IF(PLVL2) + + !$OMP DO SCHEDULE(STATIC) + DO I = 1, N + ! Check that P* is on the appropriate halfspace. + SIDE2 = (PTS(1,I) - PLANE(2)) * SIDE1 + IF (SIDE2 < EPSL .OR. SIMPS(1,MI) .EQ. I) CYCLE + ! Check that P* is closer than the current solution. + IF (SIDE2 > MINRAD) CYCLE + ! Update the minimum distance and save the index I. + MINRAD_PRIV = SIDE2 + VERTEX_PRIV = I + END DO + !$OMP END DO + !$OMP CRITICAL(REDUC_4) + ! Check if PTS(:,VERTEX_PRIV) is inside the circumball. + IF (VERTEX_PRIV .NE. 0) THEN + IF (MINRAD_PRIV < MINRAD) THEN + MINRAD = MINRAD_PRIV + SIMPS(2,MI) = VERTEX_PRIV + END IF + END IF + !$OMP END CRITICAL(REDUC_4) + !$OMP END PARALLEL + ! Check for extrapolation condition. + IF(SIMPS(2,MI) .NE. 0) THEN + ! Add new point to the linear system. + AT(1,1) = PTS(1,SIMPS(2,MI)) - PTS(1,SIMPS(1,MI)) + B(1) = (AT(1,1) ** 2.0_R8) / 2.0_R8 + END IF +END IF +! RETURN +! END SUBROUTINE MAKESIMPLEX +! End of in-lined code for MAKESIMPLEX(). +!****************************************************************************** + + + END DO + ! If the loop terminates, then a good direction was found. + ! Resume the visibility walk as normal. + CYCLE INNER + END IF + + ! Otherwise, project the extrapolation point onto the convex hull. +! CALL PROJECT(); IF (IERR_PRIV .NE. 0) CYCLE OUTER + + +!****************************************************************************** +! Due to OpenMP's handling of variable scope, the parallel (identical to serial) +! implementation of the subroutine PROJECT() has been in-lined here. +! +! SUBROUTINE PROJECT() +! Project a point outside the convex hull of the point set onto the convex hull +! by solving an inequality constrained least squares problem. The solution to +! the least squares problem gives the projection as a convex combination of the +! data points. The projection can then be computed by performing a matrix +! vector multiplication. + +! Allocate work arrays. +IF (.NOT. ALLOCATED(IWORK_DWNNLS)) THEN + ALLOCATE(IWORK_DWNNLS(D+1+N), STAT=IERR_PRIV) + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 70 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF +END IF +IF (.NOT. ALLOCATED(WORK_DWNNLS)) THEN + ALLOCATE(WORK_DWNNLS(D+1+N*5), STAT=IERR_PRIV) + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 70 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF +END IF +IF (.NOT. ALLOCATED(W_DWNNLS)) THEN + ALLOCATE(W_DWNNLS(D+1,N+1), STAT=IERR_PRIV) + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 70 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF +END IF +IF (.NOT. ALLOCATED(X_DWNNLS)) THEN + ALLOCATE(X_DWNNLS(N), STAT=IERR_PRIV) + IF(IERR_PRIV .NE. 0) THEN + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 70 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF +END IF + +! Initialize work array and settings values. +IWORK_DWNNLS(1) = D+1+5*N +IWORK_DWNNLS(2) = D+1+N +W_DWNNLS(1, :) = 1.0_R8 ! Set convexity (equality) constraint. +W_DWNNLS(2:D+1,1:N) = PTS(:,:) ! Copy data points. +W_DWNNLS(2:D+1,N+1) = PROJ(:) ! Copy extrapolation point. +! Compute the solution to the inequality constrained least squares problem to +! get the projection coefficients. +CALL DWNNLS(W_DWNNLS, D+1, 1, D, N, 0, PRGOPT_DWNNLS, X_DWNNLS, RNORML, & + IERR_PRIV, IWORK_DWNNLS, WORK_DWNNLS) +IF (IERR_PRIV .EQ. 1) THEN ! Failure to converge. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 71 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER +ELSE IF (IERR(MI) .EQ. 2) THEN ! Illegal input detected. + ! Store the error code. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 72 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER +END IF +! Compute the actual projection via matrix vector multiplication. +CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) +! Zero all weights that are approximately zero and renormalize the sum. +WHERE (X_DWNNLS < EPSL) X_DWNNLS = 0.0_R8 +X_DWNNLS(:) = X_DWNNLS(:) / SUM(X_DWNNLS) +! Compute the actual projection via matrix vector multiplication. +CALL DGEMV('N', D, N, 1.0_R8, PTS, D, X_DWNNLS, 1, 0.0_R8, PROJ, 1) +RNORML = DNRM2(D, PROJ(:) - Q(:,MI), 1) +! RETURN +! END SUBROUTINE PROJECT +! End of in-lined code for PROJECT(). +!****************************************************************************** + + + ! Check the value of RNORML for over-extrapolation. + IF (RNORML > EXTRAPL * PTS_DIAM) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! If present, record the unscaled RNORM output. + IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE + ! Set the error flag and skip this point. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 2 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + + ! Otherwise, restore the previous simplex and continue with the + ! projected value. + SIMPS(D+1,MI) = ITMP + AT(:,D) = PTS(:,ITMP) - PTS(:,SIMPS(1,MI)) + B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8 + IEXTRAPS = IEXTRAPS - 1 ! Decrement the budget. + END IF + + ! End of inner loop for finding each interpolation point. + END DO INNER + + ! Check for budget violation conditions. + IF (K > IBUDGETL) THEN + SIMPS(:,MI) = 0; WEIGHTS(:,MI) = 0 ! Zero all output values. + ! Set the error flag and skip this point. + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 60 + !$OMP END CRITICAL(CHECK_IERR) + CYCLE OUTER + END IF + + ! If the residual is nonzero, set the extrapolation flag. + IF (RNORML > EPSL) THEN + !$OMP CRITICAL(CHECK_IERR) + IERR(MI) = 1 + !$OMP END CRITICAL(CHECK_IERR) + END IF + + ! If present, record the RNORM output. + IF (PRESENT(RNORM)) RNORM(MI) = RNORML*PTS_SCALE + +END DO OUTER ! End of outer loop over all interpolation points. +!$OMP END DO + +! If INTERP_IN and INTERP_OUT are present, compute all values f(q). +IF (PRESENT(INTERP_IN)) THEN + ! Level 1 parallel loop over all interpolation points. + !$OMP DO SCHEDULE(STATIC) + DO MI = 1, M + ! Check for errors. + IF (IERR(MI) .LE. 1) THEN + ! Compute the weighted sum of vertex response values. + DO K = 1, D+1 + INTERP_OUT(:,MI) = INTERP_OUT(:,MI) & + + INTERP_IN(:,SIMPS(K,MI)) * WEIGHTS(K,MI) + END DO + END IF + END DO + !$OMP END DO +END IF + +! Free optional work arrays. +IF (ALLOCATED(IWORK_DWNNLS)) DEALLOCATE(IWORK_DWNNLS) +IF (ALLOCATED(WORK_DWNNLS)) DEALLOCATE(WORK_DWNNLS) +IF (ALLOCATED(W_DWNNLS)) DEALLOCATE(W_DWNNLS) +IF (ALLOCATED(X_DWNNLS)) DEALLOCATE(X_DWNNLS) +!$OMP END PARALLEL +! End of Level 1 parallel region. + +! Free dynamic work arrays. +DEALLOCATE(WORK) + +RETURN + +CONTAINS ! Internal subroutines and functions. + +SUBROUTINE RESCALE(MINDIST, DIAMETER, SCALE) +! Rescale and transform data to be centered at the origin with unit +! radius. +! +! The parallel implementation of this subroutine exploits parallelism +! over loops of length N. For nested loops, this subroutine follows +! the OpenMP recommendation of a static schedule with a fixed chunk +! size (of 100). +! +! On output, PTS and Q have been rescaled and shifted. All the data +! points in PTS are centered with unit radius, and the points in Q +! have been shifted and scaled in relation to PTS. +! +! MINDIST is a real number containing the (scaled) minimum distance +! between any two data points in PTS. +! +! DIAMETER is a real number containing the (scaled) diameter of the +! data set PTS. +! +! SCALE contains the real factor used to transform the data and +! interpolation points: scaled value = (original value - +! barycenter of data points)/SCALE. + +! Output arguments. +REAL(KIND=R8), INTENT(OUT) :: MINDIST, DIAMETER, SCALE + +! Local variables. +REAL(KIND=R8) :: PTS_CENTER(D) ! The center of the data points PTS. +REAL(KIND=R8) :: DISTANCE ! The current distance. + +! Initialize local values. +MINDIST = HUGE(0.0_R8) +DIAMETER = 0.0_R8 +SCALE = 0.0_R8 + +! Compute barycenter of all data points. +PTS_CENTER(:) = SUM(PTS(:,:), DIM=2)/REAL(N, KIND=R8) +! Center the points. +FORALL (I = 1:N) PTS(:,I) = PTS(:,I) - PTS_CENTER(:) +! Compute the scale factor (for unit radius). +!$OMP PARALLEL DO & +!$OMP& PRIVATE(I, DISTANCE), & +!$OMP& REDUCTION(MAX:SCALE), & +!$OMP& SCHEDULE(STATIC), & +!$OMP& DEFAULT(SHARED) +DO I = 1, N ! Cycle through all points again. + DISTANCE = DNRM2(D, PTS(:,I), 1) ! Compute the distance from the center. + IF (DISTANCE > SCALE) THEN ! Compare to the current radius. + SCALE = DISTANCE + END IF +END DO +!$OMP END PARALLEL DO +! Scale the points to unit radius. +PTS = PTS / SCALE +! Also transform Q similarly. +FORALL (I = 1:M) Q(:,I) = (Q(:,I) - PTS_CENTER(:)) / SCALE +! Compute the minimum and maximum distances. +IF (EXACTL) THEN + ! If exact error error checking is turned on, then compute the DIAMETER + ! and MINDIST values. + !$OMP PARALLEL DO & + !$OMP& PRIVATE(I, DISTANCE), & + !$OMP& REDUCTION(MAX:DIAMETER), & + !$OMP& REDUCTION(MIN:MINDIST), & + !$OMP& SCHEDULE(STATIC, 100), & + !$OMP& DEFAULT(SHARED) + DO I = 1, N ! Cycle through all pairs of points. + DO J = I + 1, N + DISTANCE = DNRM2(D, PTS(:,I) - PTS(:,J), 1) ! Compute the distance. + IF (DISTANCE > DIAMETER) THEN ! Compare to the current diameter. + DIAMETER = DISTANCE + END IF + IF (DISTANCE < MINDIST) THEN ! Compare to the current minimum distance. + MINDIST = DISTANCE + END IF + END DO + END DO + !$OMP END PARALLEL DO +ELSE + ! If exact error checking is turned off, then the diameter is approximately + ! 2.0 after rescaling and centering the points. The MINDIST is not computed. + DIAMETER = 2.0_R8 + MINDIST = 1.0_R8 +END IF +RETURN +END SUBROUTINE RESCALE + +END SUBROUTINE DELAUNAYSPARSEP diff --git a/python/delsparse_src/delsparse_bind_c.f90 b/python/delsparse_src/delsparse_bind_c.f90 new file mode 100644 index 0000000..8bf2973 --- /dev/null +++ b/python/delsparse_src/delsparse_bind_c.f90 @@ -0,0 +1,4422 @@ +! This automatically generated Fortran wrapper file allows codes +! written in Fortran to be called directly from C and translates all +! C-style arguments into expected Fortran-style arguments (with +! assumed size, local type declarations, etc.). + + +SUBROUTINE C_DELAUNAYSPARSES(D, N, PTS_DIM_1, PTS_DIM_2, PTS, M, Q_DIM_1, Q_DIM_2, Q, SIMPS_DIM_1, SIMPS_DIM_2, SIMPS, WEIGHTS_DIM_& +&1, WEIGHTS_DIM_2, WEIGHTS, IERR_DIM_1, IERR, INTERP_IN_PRESENT, INTERP_IN_DIM_1, INTERP_IN_DIM_2, INTERP_IN, INTERP_OUT_PRESENT, I& +&NTERP_OUT_DIM_1, INTERP_OUT_DIM_2, INTERP_OUT, EPS_PRESENT, EPS, EXTRAP_PRESENT, EXTRAP, RNORM_PRESENT, RNORM_DIM_1, RNORM, IBUDGE& +&T_PRESENT, IBUDGET, CHAIN_PRESENT, CHAIN, EXACT_PRESENT, EXACT) BIND(C) +USE REAL_PRECISION , ONLY : R8 + IMPLICIT NONE + + INTEGER, INTENT(IN) :: D + + INTEGER, INTENT(IN) :: N + + INTEGER, INTENT(IN) :: PTS_DIM_1 + INTEGER, INTENT(IN) :: PTS_DIM_2 + REAL(KIND=R8), INTENT(INOUT), DIMENSION(PTS_DIM_1,PTS_DIM_2) :: PTS + + INTEGER, INTENT(IN) :: M + + INTEGER, INTENT(IN) :: Q_DIM_1 + INTEGER, INTENT(IN) :: Q_DIM_2 + REAL(KIND=R8), INTENT(INOUT), DIMENSION(Q_DIM_1,Q_DIM_2) :: Q + + INTEGER, INTENT(IN) :: SIMPS_DIM_1 + INTEGER, INTENT(IN) :: SIMPS_DIM_2 + INTEGER, INTENT(OUT), DIMENSION(SIMPS_DIM_1,SIMPS_DIM_2) :: SIMPS + + INTEGER, INTENT(IN) :: WEIGHTS_DIM_1 + INTEGER, INTENT(IN) :: WEIGHTS_DIM_2 + REAL(KIND=R8), INTENT(OUT), DIMENSION(WEIGHTS_DIM_1,WEIGHTS_DIM_2) :: WEIGHTS + + INTEGER, INTENT(IN) :: IERR_DIM_1 + INTEGER, INTENT(OUT), DIMENSION(IERR_DIM_1) :: IERR + + LOGICAL, INTENT(IN) :: INTERP_IN_PRESENT + INTEGER, INTENT(IN) :: INTERP_IN_DIM_1 + INTEGER, INTENT(IN) :: INTERP_IN_DIM_2 + REAL(KIND=R8), INTENT(IN), DIMENSION(INTERP_IN_DIM_1,INTERP_IN_DIM_2) :: INTERP_IN + + LOGICAL, INTENT(IN) :: INTERP_OUT_PRESENT + INTEGER, INTENT(IN) :: INTERP_OUT_DIM_1 + INTEGER, INTENT(IN) :: INTERP_OUT_DIM_2 + REAL(KIND=R8), INTENT(OUT), DIMENSION(INTERP_OUT_DIM_1,INTERP_OUT_DIM_2) :: INTERP_OUT + + LOGICAL, INTENT(IN) :: EPS_PRESENT + REAL(KIND=R8), INTENT(IN) :: EPS + + LOGICAL, INTENT(IN) :: EXTRAP_PRESENT + REAL(KIND=R8), INTENT(IN) :: EXTRAP + + LOGICAL, INTENT(IN) :: RNORM_PRESENT + INTEGER, INTENT(IN) :: RNORM_DIM_1 + REAL(KIND=R8), INTENT(OUT), DIMENSION(RNORM_DIM_1) :: RNORM + + LOGICAL, INTENT(IN) :: IBUDGET_PRESENT + INTEGER, INTENT(IN) :: IBUDGET + + LOGICAL, INTENT(IN) :: CHAIN_PRESENT + LOGICAL, INTENT(IN) :: CHAIN + + LOGICAL, INTENT(IN) :: EXACT_PRESENT + LOGICAL, INTENT(IN) :: EXACT + + INTERFACE + SUBROUTINE DELAUNAYSPARSES(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EX& +&ACT) + ! This is a serial implementation of an algorithm for efficiently performing + ! interpolation in R^D via the Delaunay triangulation. The algorithm is fully + ! described and analyzed in + ! + ! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. + ! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate + ! interpolation in arbitrary dimension via the Delaunay triangulation. In + ! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, + ! USA. Article 12, 8 pages. + ! + ! + ! On input: + ! + ! D is the dimension of the space for PTS and Q. + ! + ! N is the number of data points in PTS. + ! + ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the + ! coordinates of a single data point in R^D. + ! + ! M is the number of interpolation points in Q. + ! + ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the + ! coordinates of a single interpolation point in R^D. + ! + ! + ! On output: + ! + ! PTS and Q have been rescaled and shifted. All the data points in PTS + ! are now contained in the unit hyperball in R^D, and the points in Q + ! have been shifted and scaled accordingly in relation to PTS. + ! + ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns + ! in PTS) for the D+1 vertices of the Delaunay simplex containing each + ! interpolation point in Q. + ! + ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each + ! point in Q as a convex combination of the D+1 corresponding vertices + ! in SIMPS. + ! + ! IERR(1:M) contains integer valued error flags associated with the + ! computation of each of the M interpolation points in Q. The error + ! codes are: + ! + ! 00 : Succesful interpolation. + ! 01 : Succesful extrapolation (up to the allowed extrapolation distance). + ! 02 : This point was outside the allowed extrapolation distance; the + ! corresponding entries in SIMPS and WEIGHTS contain zero values. + ! + ! 10 : The dimension D must be positive. + ! 11 : Too few data points to construct a triangulation (i.e., N < D+1). + ! 12 : No interpolation points given (i.e., M < 1). + ! 13 : The first dimension of PTS does not agree with the dimension D. + ! 14 : The second dimension of PTS does not agree with the number of points N. + ! 15 : The first dimension of Q does not agree with the dimension D. + ! 16 : The second dimension of Q does not agree with the number of + ! interpolation points M. + ! 17 : The first dimension of the output array SIMPS does not match the number + ! of vertices needed for a D-simplex (D+1). + ! 18 : The second dimension of the output array SIMPS does not match the + ! number of interpolation points M. + ! 19 : The first dimension of the output array WEIGHTS does not match the + ! number of vertices for a a D-simplex (D+1). + ! 20 : The second dimension of the output array WEIGHTS does not match the + ! number of interpolation points M. + ! 21 : The size of the error array IERR does not match the number of + ! interpolation points M. + ! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. + ! 23 : The first dimension of INTERP_IN does not match the first + ! dimension of INTERP_OUT. + ! 24 : The second dimension of INTERP_IN does not match the number of + ! data points PTS. + ! 25 : The second dimension of INTERP_OUT does not match the number of + ! interpolation points M. + ! 26 : The budget supplied in IBUDGET does not contain a positive + ! integer. + ! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. + ! 28 : The size of the RNORM output array does not match the number of + ! interpolation points M. + ! + ! 30 : Two or more points in the data set PTS are too close together with + ! respect to the working precision (EPS), which would result in a + ! numerically degenerate simplex. + ! 31 : All the data points in PTS lie in some lower dimensional linear + ! manifold (up to the working precision), and no valid triangulation + ! exists. + ! 40 : An error caused DELAUNAYSPARSES to terminate before this value could + ! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may + ! contain garbage values. + ! + ! 50 : A memory allocation error occurred while allocating the work array + ! WORK. + ! + ! 60 : The budget was exceeded before the algorithm converged on this + ! value. If the dimension is high, try increasing IBUDGET. This + ! error can also be caused by a working precision EPS that is too + ! small for the conditioning of the problem. + ! + ! 61 : A value that was judged appropriate later caused LAPACK to encounter a + ! singularity. Try increasing the value of EPS. + ! + ! 70 : Allocation error for the extrapolation work arrays. + ! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection + ! of an extrapolation point onto the convex hull. + ! 72 : The SLATEC subroutine DWNNLS has reported a usage error. + ! + ! The errors 72, 80--83 should never occur, and likely indicate a + ! compiler bug or hardware failure. + ! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. + ! 81 : The LAPACK subroutine DGETRF has reported an illegal value. + ! 82 : The LAPACK subroutine DGETRS has reported an illegal value. + ! 83 : The LAPACK subroutine DORMQR has reported an illegal value. + ! + ! + ! Optional arguments: + ! + ! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of + ! the data points in PTS on input. The first dimension of INTERP_IN is + ! inferred to be the dimension of these response vectors, and the + ! second dimension must match N. If present, the response values will + ! be computed for each interpolation point in Q, and stored in INTERP_OUT, + ! which therefore must also be present. If both INTERP_IN and INTERP_OUT + ! are omitted, only the containing simplices and convex combination + ! weights are returned. + ! + ! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each + ! interpolation point in Q on output. The first dimension of INTERP_OUT + ! must match the first dimension of INTERP_IN, and the second dimension + ! must match M. If present, the response values at each interpolation + ! point are computed as a convex combination of the response values + ! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing + ! that interpolation point. Therefore, if INTERP_OUT is present, then + ! INTERP_IN must also be present. If both are omitted, only the + ! simplices and convex combination weights are returned. + ! + ! EPS contains the real working precision for the problem on input. By default, + ! EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff for the + ! machine. In general, any values that differ by less than EPS are judged + ! as equal, and any weights that are greater than -EPS are judged as + ! nonnegative. EPS cannot take a value less than the default value of + ! \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, the default + ! value will be used instead automatically. + ! + ! EXTRAP contains the real maximum extrapolation distance (relative to the + ! diameter of PTS) on input. Interpolation at a point outside the convex + ! hull of PTS is done by projecting that point onto the convex hull, and + ! then doing normal Delaunay interpolation at that projection. + ! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) + ! units outside the convex hull of PTS will not be done and an error code + ! of 2 will be returned. Note that computing the projection can be + ! expensive. Setting EXTRAP=0 will cause all extrapolation points to be + ! ignored without ever computing a projection. By default, EXTRAP=0.1 + ! (extrapolate by up to 10% of the diameter of PTS). + ! + ! RNORM(1:M) contains the real unscaled projection (2-norm) distances from + ! any projection computations on output. If not present, these distances + ! are still computed for each extrapolation point, but are never returned. + ! + ! IBUDGET on input contains the integer budget for performing flips while + ! iterating toward the simplex containing each interpolation point in + ! Q. This prevents DELAUNAYSPARSES from falling into an infinite loop when + ! an inappropriate value of EPS is given with respect to the problem + ! conditioning. By default, IBUDGET=50000. However, for extremely + ! high-dimensional problems and pathological inputs, the default value + ! may be insufficient. + ! + ! CHAIN is a logical input argument that determines whether a new first + ! simplex should be constructed for each interpolation point + ! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." + ! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not + ! recommended, unless the size of the triangulation is relatively small + ! or the interpolation points are known to be tightly clustered. + ! + ! EXACT is a logical input argument that determines whether the exact + ! diameter should be computed and whether a check for duplicate data + ! points should be performed in advance. When EXACT=.FALSE., the + ! diameter of PTS is approximated by twice the distance from the + ! barycenter of PTS to the farthest point in PTS, and no check is + ! done to find the closest pair of points, which could result in hard + ! to find bugs later on. When EXACT=.TRUE., the exact diameter is + ! computed and an error is returned whenever PTS contains duplicate + ! values up to the precision EPS. By default EXACT=.TRUE., but setting + ! EXACT=.FALSE. could result in significant speedup when N is large. + ! It is strongly recommended that most users leave EXACT=.TRUE., as + ! setting EXACT=.FALSE. could result in input errors that are difficult + ! to identify. Also, the diameter approximation could be wrong by up to + ! a factor of two. + ! + ! + ! Subroutines and functions directly referenced from BLAS are + ! DDOT, DGEMV, DNRM2, DTRSM, + ! and from LAPACK are + ! DGEQP3, DGETRF, DGETRS, DORMQR. + ! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its + ! SLATEC dependencies have been slightly edited to comply with the Fortran + ! 2008 standard, with all print statements and references to stderr being + ! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 + ! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS + ! Algorithm 777) is used for the real data type. The REAL_PRECISION module, + ! DELAUNAYSPARSES, and DWNNLS and its dependencies comply with the Fortran + ! 2008 standard. + ! + ! Primary Author: Tyler H. Chang + ! Last Update: March, 2020 + ! + USE REAL_PRECISION , ONLY : R8 + IMPLICIT NONE + INTEGER, INTENT(IN) :: D + INTEGER, INTENT(IN) :: N + REAL(KIND=R8), INTENT(INOUT), DIMENSION(:,:) :: PTS + INTEGER, INTENT(IN) :: M + REAL(KIND=R8), INTENT(INOUT), DIMENSION(:,:) :: Q + INTEGER, INTENT(OUT), DIMENSION(:,:) :: SIMPS + REAL(KIND=R8), INTENT(OUT), DIMENSION(:,:) :: WEIGHTS + INTEGER, INTENT(OUT), DIMENSION(:) :: IERR + REAL(KIND=R8), INTENT(IN), OPTIONAL, DIMENSION(:,:) :: INTERP_IN + REAL(KIND=R8), INTENT(OUT), OPTIONAL, DIMENSION(:,:) :: INTERP_OUT + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP + REAL(KIND=R8), INTENT(OUT), OPTIONAL, DIMENSION(:) :: RNORM + INTEGER, INTENT(IN), OPTIONAL :: IBUDGET + LOGICAL, INTENT(IN), OPTIONAL :: CHAIN + LOGICAL, INTENT(IN), OPTIONAL :: EXACT + END SUBROUTINE DELAUNAYSPARSES + END INTERFACE + + IF (INTERP_IN_PRESENT) THEN + IF (INTERP_OUT_PRESENT) THEN + IF (EPS_PRESENT) THEN + IF (EXTRAP_PRESENT) THEN + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM) + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP) + END IF + END IF + END IF + END IF + ELSE + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM) + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EPS=EPS) + END IF + END IF + END IF + END IF + END IF + ELSE + IF (EXTRAP_PRESENT) THEN + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM) + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP) + END IF + END IF + END IF + END IF + ELSE + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, RNORM=RNORM, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, RNORM=RNORM, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, RNORM=RNORM) + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&NTERP_OUT=INTERP_OUT) + END IF + END IF + END IF + END IF + END IF + END IF + ELSE + IF (EPS_PRESENT) THEN + IF (EXTRAP_PRESENT) THEN + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXTRAP=EXTRAP, RNORM=RNORM) + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXTRAP=EXTRAP, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXTRAP=EXTRAP) + END IF + END IF + END IF + END IF + ELSE + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, RNORM=RNORM, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, RNORM=RNORM, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, RNORM=RNORM) + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&PS=EPS) + END IF + END IF + END IF + END IF + END IF + ELSE + IF (EXTRAP_PRESENT) THEN + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XTRAP=EXTRAP, RNORM=RNORM) + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XTRAP=EXTRAP, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XTRAP=EXTRAP, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XTRAP=EXTRAP, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XTRAP=EXTRAP) + END IF + END IF + END IF + END IF + ELSE + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, R& +&NORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, R& +&NORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, R& +&NORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, R& +&NORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, R& +&NORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, R& +&NORM=RNORM, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, R& +&NORM=RNORM, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, R& +&NORM=RNORM) + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&BUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&BUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&BUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, I& +&BUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, C& +&HAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, C& +&HAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN, E& +&XACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN) + END IF + END IF + END IF + END IF + END IF + END IF + END IF + ELSE + IF (INTERP_OUT_PRESENT) THEN + IF (EPS_PRESENT) THEN + IF (EXTRAP_PRESENT) THEN + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM) + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXTRAP=EXTRAP, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXTRAP=EXTRAP) + END IF + END IF + END IF + END IF + ELSE + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, RNORM=RNORM, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, RNORM=RNORM, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, RNORM=RNORM) + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EPS=EPS) + END IF + END IF + END IF + END IF + END IF + ELSE + IF (EXTRAP_PRESENT) THEN + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXTRAP=EXTRAP, RNORM=RNORM) + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXTRAP=EXTRAP, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXTRAP=EXTRAP, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXTRAP=EXTRAP, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXTRAP=EXTRAP) + END IF + END IF + END IF + END IF + ELSE + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& RNORM=RNORM, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& RNORM=RNORM, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& RNORM=RNORM) + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT,& +& EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OUT) + END IF + END IF + END IF + END IF + END IF + END IF + ELSE + IF (EPS_PRESENT) THEN + IF (EXTRAP_PRESENT) THEN + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& +&, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& +&, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& +&, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& +&, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& +&, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& +&, RNORM=RNORM, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& +&, RNORM=RNORM, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& +&, RNORM=RNORM) + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& +&, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& +&, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& +&, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& +&, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& +&, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& +&, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& +&, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTRAP& +&) + END IF + END IF + END IF + END IF + ELSE + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM, & +&IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM, & +&IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM, & +&IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM, & +&IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM, & +&CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM, & +&CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM, & +&EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM) + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBUDG& +&ET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBUDG& +&ET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBUDG& +&ET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBUDG& +&ET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, CHAIN=CHAIN, & +&EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS) + END IF + END IF + END IF + END IF + END IF + ELSE + IF (EXTRAP_PRESENT) THEN + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM=R& +&NORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM=R& +&NORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM=R& +&NORM, IBUDGET=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM=R& +&NORM, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM=R& +&NORM, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM=R& +&NORM, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM=R& +&NORM, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM=R& +&NORM) + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDGET& +&=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDGET& +&=IBUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDGET& +&=IBUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDGET& +&=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, CHAIN=C& +&HAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, CHAIN=C& +&HAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, EXACT=E& +&XACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP) + END IF + END IF + END IF + END IF + ELSE + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET=I& +&BUDGET, CHAIN=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET=I& +&BUDGET, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET=I& +&BUDGET, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET=I& +&BUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, CHAIN=CHA& +&IN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, CHAIN=CHA& +&IN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, EXACT=EXA& +&CT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM) + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, CHAIN& +&=CHAIN, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, CHAIN& +&=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, EXACT& +&=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET) + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, CHAIN=CHAIN, EXACT=EXA& +&CT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, CHAIN=CHAIN) + END IF + ELSE + IF (EXACT_PRESENT) THEN + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXACT=EXACT) + ELSE + CALL DELAUNAYSPARSES(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR) + END IF + END IF + END IF + END IF + END IF + END IF + END IF + END IF +END SUBROUTINE C_DELAUNAYSPARSES + + +SUBROUTINE C_DELAUNAYSPARSEP(D, N, PTS_DIM_1, PTS_DIM_2, PTS, M, Q_DIM_1, Q_DIM_2, Q, SIMPS_DIM_1, SIMPS_DIM_2, SIMPS, WEIGHTS_DIM_& +&1, WEIGHTS_DIM_2, WEIGHTS, IERR_DIM_1, IERR, INTERP_IN_PRESENT, INTERP_IN_DIM_1, INTERP_IN_DIM_2, INTERP_IN, INTERP_OUT_PRESENT, I& +&NTERP_OUT_DIM_1, INTERP_OUT_DIM_2, INTERP_OUT, EPS_PRESENT, EPS, EXTRAP_PRESENT, EXTRAP, RNORM_PRESENT, RNORM_DIM_1, RNORM, IBUDGE& +&T_PRESENT, IBUDGET, CHAIN_PRESENT, CHAIN, EXACT_PRESENT, EXACT, PMODE_PRESENT, PMODE) BIND(C) +USE REAL_PRECISION , ONLY : R8 + IMPLICIT NONE + + INTEGER, INTENT(IN) :: D + + INTEGER, INTENT(IN) :: N + + INTEGER, INTENT(IN) :: PTS_DIM_1 + INTEGER, INTENT(IN) :: PTS_DIM_2 + REAL(KIND=R8), INTENT(INOUT), DIMENSION(PTS_DIM_1,PTS_DIM_2) :: PTS + + INTEGER, INTENT(IN) :: M + + INTEGER, INTENT(IN) :: Q_DIM_1 + INTEGER, INTENT(IN) :: Q_DIM_2 + REAL(KIND=R8), INTENT(INOUT), DIMENSION(Q_DIM_1,Q_DIM_2) :: Q + + INTEGER, INTENT(IN) :: SIMPS_DIM_1 + INTEGER, INTENT(IN) :: SIMPS_DIM_2 + INTEGER, INTENT(OUT), DIMENSION(SIMPS_DIM_1,SIMPS_DIM_2) :: SIMPS + + INTEGER, INTENT(IN) :: WEIGHTS_DIM_1 + INTEGER, INTENT(IN) :: WEIGHTS_DIM_2 + REAL(KIND=R8), INTENT(OUT), DIMENSION(WEIGHTS_DIM_1,WEIGHTS_DIM_2) :: WEIGHTS + + INTEGER, INTENT(IN) :: IERR_DIM_1 + INTEGER, INTENT(OUT), DIMENSION(IERR_DIM_1) :: IERR + + LOGICAL, INTENT(IN) :: INTERP_IN_PRESENT + INTEGER, INTENT(IN) :: INTERP_IN_DIM_1 + INTEGER, INTENT(IN) :: INTERP_IN_DIM_2 + REAL(KIND=R8), INTENT(IN), DIMENSION(INTERP_IN_DIM_1,INTERP_IN_DIM_2) :: INTERP_IN + + LOGICAL, INTENT(IN) :: INTERP_OUT_PRESENT + INTEGER, INTENT(IN) :: INTERP_OUT_DIM_1 + INTEGER, INTENT(IN) :: INTERP_OUT_DIM_2 + REAL(KIND=R8), INTENT(OUT), DIMENSION(INTERP_OUT_DIM_1,INTERP_OUT_DIM_2) :: INTERP_OUT + + LOGICAL, INTENT(IN) :: EPS_PRESENT + REAL(KIND=R8), INTENT(IN) :: EPS + + LOGICAL, INTENT(IN) :: EXTRAP_PRESENT + REAL(KIND=R8), INTENT(IN) :: EXTRAP + + LOGICAL, INTENT(IN) :: RNORM_PRESENT + INTEGER, INTENT(IN) :: RNORM_DIM_1 + REAL(KIND=R8), INTENT(OUT), DIMENSION(RNORM_DIM_1) :: RNORM + + LOGICAL, INTENT(IN) :: IBUDGET_PRESENT + INTEGER, INTENT(IN) :: IBUDGET + + LOGICAL, INTENT(IN) :: CHAIN_PRESENT + LOGICAL, INTENT(IN) :: CHAIN + + LOGICAL, INTENT(IN) :: EXACT_PRESENT + LOGICAL, INTENT(IN) :: EXACT + + LOGICAL, INTENT(IN) :: PMODE_PRESENT + INTEGER, INTENT(IN) :: PMODE + + INTERFACE + SUBROUTINE DELAUNAYSPARSEP(D, N, PTS, M, Q, SIMPS, WEIGHTS, IERR, INTERP_IN, INTERP_OUT, EPS, EXTRAP, RNORM, IBUDGET, CHAIN, EX& +&ACT, PMODE) + ! This is a parallel implementation of an algorithm for efficiently performing + ! interpolation in R^D via the Delaunay triangulation. The algorithm is fully + ! described and analyzed in + ! + ! T. H. Chang, L. T. Watson, T. C.H. Lux, B. Li, L. Xu, A. R. Butt, K. W. + ! Cameron, and Y. Hong. 2018. A polynomial time algorithm for multivariate + ! interpolation in arbitrary dimension via the Delaunay triangulation. In + ! Proceedings of the ACMSE 2018 Conference (ACMSE '18). ACM, New York, NY, + ! USA. Article 12, 8 pages. + ! + ! + ! On input: + ! + ! D is the dimension of the space for PTS and Q. + ! + ! N is the number of data points in PTS. + ! + ! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the + ! coordinates of a single data point in R^D. + ! + ! M is the number of interpolation points in Q. + ! + ! Q(1:D,1:M) is a real valued matrix with M columns, each containing the + ! coordinates of a single interpolation point in R^D. + ! + ! + ! On output: + ! + ! PTS and Q have been rescaled and shifted. All the data points in PTS + ! are now contained in the unit hyperball in R^D, and the points in Q + ! have been shifted and scaled accordingly in relation to PTS. + ! + ! SIMPS(1:D+1,1:M) contains the D+1 integer indices (corresponding to columns + ! in PTS) for the D+1 vertices of the Delaunay simplex containing each + ! interpolation point in Q. + ! + ! WEIGHTS(1:D+1,1:M) contains the D+1 real valued weights for expressing each + ! point in Q as a convex combination of the D+1 corresponding vertices + ! in SIMPS. + ! + ! IERR(1:M) contains integer valued error flags associated with the + ! computation of each of the M interpolation points in Q. The error + ! codes are: + ! + ! 00 : Succesful interpolation. + ! 01 : Succesful extrapolation (up to the allowed extrapolation distance). + ! 02 : This point was outside the allowed extrapolation distance; the + ! corresponding entries in SIMPS and WEIGHTS contain zero values. + ! + ! 10 : The dimension D must be positive. + ! 11 : Too few data points to construct a triangulation (i.e., N < D+1). + ! 12 : No interpolation points given (i.e., M < 1). + ! 13 : The first dimension of PTS does not agree with the dimension D. + ! 14 : The second dimension of PTS does not agree with the number of points N. + ! 15 : The first dimension of Q does not agree with the dimension D. + ! 16 : The second dimension of Q does not agree with the number of + ! interpolation points M. + ! 17 : The first dimension of the output array SIMPS does not match the number + ! of vertices needed for a D-simplex (D+1). + ! 18 : The second dimension of the output array SIMPS does not match the + ! number of interpolation points M. + ! 19 : The first dimension of the output array WEIGHTS does not match the + ! number of vertices for a a D-simplex (D+1). + ! 20 : The second dimension of the output array WEIGHTS does not match the + ! number of interpolation points M. + ! 21 : The size of the error array IERR does not match the number of + ! interpolation points M. + ! 22 : INTERP_IN cannot be present without INTERP_OUT or vice versa. + ! 23 : The first dimension of INTERP_IN does not match the first + ! dimension of INTERP_OUT. + ! 24 : The second dimension of INTERP_IN does not match the number of + ! data points PTS. + ! 25 : The second dimension of INTERP_OUT does not match the number of + ! interpolation points M. + ! 26 : The budget supplied in IBUDGET does not contain a positive + ! integer. + ! 27 : The extrapolation distance supplied in EXTRAP cannot be negative. + ! 28 : The size of the RNORM output array does not match the number of + ! interpolation points M. + ! + ! 30 : Two or more points in the data set PTS are too close together with + ! respect to the working precision (EPS), which would result in a + ! numerically degenerate simplex. + ! 31 : All the data points in PTS lie in some lower dimensional linear + ! manifold (up to the working precision), and no valid triangulation + ! exists. + ! 40 : An error caused DELAUNAYSPARSEP to terminate before this value could + ! be computed. Note: The corresponding entries in SIMPS and WEIGHTS may + ! contain garbage values. + ! + ! 50 : A memory allocation error occurred while allocating the work array + ! WORK. + ! + ! 60 : The budget was exceeded before the algorithm converged on this + ! value. If the dimension is high, try increasing IBUDGET. This + ! error can also be caused by a working precision EPS that is too + ! small for the conditioning of the problem. + ! + ! 61 : A value that was judged appropriate later caused LAPACK to encounter a + ! singularity. Try increasing the value of EPS. + ! + ! 70 : Allocation error for the extrapolation work arrays. + ! 71 : The SLATEC subroutine DWNNLS failed to converge during the projection + ! of an extrapolation point onto the convex hull. + ! 72 : The SLATEC subroutine DWNNLS has reported a usage error. + ! + ! The errors 72, 80--83 should never occur, and likely indicate a + ! compiler bug or hardware failure. + ! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value. + ! 81 : The LAPACK subroutine DGETRF has reported an illegal value. + ! 82 : The LAPACK subroutine DGETRS has reported an illegal value. + ! 83 : The LAPACK subroutine DORMQR has reported an illegal value. + ! + ! 90 : The value of PMODE is not valid. + ! + ! + ! Optional arguments: + ! + ! INTERP_IN(1:IR,1:N) contains real valued response vectors for each of + ! the data points in PTS on input. The first dimension of INTERP_IN is + ! inferred to be the dimension of these response vectors, and the + ! second dimension must match N. If present, the response values will + ! be computed for each interpolation point in Q, and stored in INTERP_OUT, + ! which therefore must also be present. If both INTERP_IN and INTERP_OUT + ! are omitted, only the containing simplices and convex combination + ! weights are returned. + ! + ! INTERP_OUT(1:IR,1:M) contains real valued response vectors for each + ! interpolation point in Q on output. The first dimension of INTERP_OU + ! must match the first dimension of INTERP_IN, and the second dimension + ! must match M. If present, the response values at each interpolation + ! point are computed as a convex combination of the response values + ! (supplied in INTERP_IN) at the vertices of a Delaunay simplex containing + ! that interpolation point. Therefore, if INTERP_OUT is present, then + ! INTERP_IN must also be present. If both are omitted, only the + ! simplices and convex combination weights are returned. + ! + ! EPS contains the real working precision for the problem on input. By + ! default, EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff + ! for the machine. In general, any values that differ by less than EPS + ! are judged as equal, and any weights that are greater than -EPS are + ! judged as nonnegative. EPS cannot take a value less than the default + ! value of \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, + ! the default value will be used instead automatically. + ! + ! EXTRAP contains the real maximum extrapolation distance (relative to the + ! diameter of PTS) on input. Interpolation at a point outside the convex + ! hull of PTS is done by projecting that point onto the convex hull, and + ! then doing normal Delaunay interpolation at that projection. + ! Interpolation at any point in Q that is more than EXTRAP * DIAMETER(PTS) + ! units outside the convex hull of PTS will not be done and an error code + ! of 2 will be returned. Note that computing the projection can be + ! expensive. Setting EXTRAP=0 will cause all extrapolation points to be + ! ignored without ever computing a projection. By default, EXTRAP=0.1 + ! (extrapolate by up to 10% of the diameter of PTS). + ! + ! RNORM(1:M) contains the real unscaled projection (2-norm) distances from + ! any projection computations on output. If not present, these distances + ! are still computed for each extrapolation point, but are never returned. + ! + ! IBUDGET on input contains the integer budget for performing flips while + ! iterating toward the simplex containing each interpolation point in Q. + ! This prevents DELAUNAYSPARSEP from falling into an infinite loop when + ! an inappropriate value of EPS is given with respect to the problem + ! conditioning. By default, IBUDGET=50000. However, for extremely + ! high-dimensional problems and pathological inputs, the default value + ! may be insufficient. + ! + ! CHAIN is a logical input argument that determines whether a new first + ! simplex should be constructed for each interpolation point + ! (CHAIN=.FALSE.), or whether the simplex walks should be "daisy-chained." + ! By default, CHAIN=.FALSE. Setting CHAIN=.TRUE. is generally not + ! recommended, unless the size of the triangulation is relatively small + ! or the interpolation points are known to be tightly clustered. + ! + ! EXACT is a logical input argument that determines whether the exact + ! diameter should be computed and whether a check for duplicate data + ! points should be performed in advance. When EXACT=.FALSE., the + ! diameter of PTS is approximated by twice the distance from the + ! barycenter of PTS to the farthest point in PTS, and no check is + ! done to find the closest pair of points, which could result in hard + ! to find bugs later on. When EXACT=.TRUE., the exact diameter is + ! computed and an error is returned whenever PTS contains duplicate + ! values up to the precision EPS. By default EXACT=.TRUE., but setting + ! EXACT=.FALSE. could result in significant speedup when N is large. + ! It is strongly recommended that most users leave EXACT=.TRUE., as + ! setting EXACT=.FALSE. could result in input errors that are difficult + ! to identify. Also, the diameter approximation could be wrong by up to + ! a factor of two. + ! + ! PMODE is an integer specifying the level of parallelism to be exploited. + ! If PMODE = 1, then parallelism is exploited at the level of the loop + ! over all interpolation points (Level 1 parallelism). + ! If PMODE = 2, then parallelism is exploited at the level of the loops + ! over data points when constructing/flipping simplices (Level 2 + ! parallelism). + ! If PMODE = 3, then parallelism is exploited at both levels. Note: this + ! implies that the total number of threads active at any time could be up + ! to OMP_NUM_THREADS^2. + ! By default, PMODE is set to 1 if there is more than 1 interpolation + ! point and 2 otherwise. + ! + ! + ! Subroutines and functions directly referenced from BLAS are + ! DDOT, DGEMV, DNRM2, DTRSM, + ! and from LAPACK are + ! DGEQP3, DGETRF, DGETRS, DORMQR. + ! The SLATEC subroutine DWNNLS is directly referenced. DWNNLS and all its + ! SLATEC dependencies have been slightly edited to comply with the Fortran + ! 2008 standard, with all print statements and references to stderr being + ! commented out. For a reference to DWNNLS, see ACM TOMS Algorithm 587 + ! (Hanson and Haskell). The module REAL_PRECISION from HOMPACK90 (ACM TOMS + ! Algorithm 777) is used for the real data type. The REAL_PRECISION module, + ! DELAUNAYSPARSEP, and DWNNLS and its dependencies comply with the Fortran + ! 2008 standard. + ! + ! Primary Author: Tyler H. Chang + ! Last Update: March, 2020 + ! + USE REAL_PRECISION , ONLY : R8 + IMPLICIT NONE + INTEGER, INTENT(IN) :: D + INTEGER, INTENT(IN) :: N + REAL(KIND=R8), INTENT(INOUT), DIMENSION(:,:) :: PTS + INTEGER, INTENT(IN) :: M + REAL(KIND=R8), INTENT(INOUT), DIMENSION(:,:) :: Q + INTEGER, INTENT(OUT), DIMENSION(:,:) :: SIMPS + REAL(KIND=R8), INTENT(OUT), DIMENSION(:,:) :: WEIGHTS + INTEGER, INTENT(OUT), DIMENSION(:) :: IERR + REAL(KIND=R8), INTENT(IN), OPTIONAL, DIMENSION(:,:) :: INTERP_IN + REAL(KIND=R8), INTENT(OUT), OPTIONAL, DIMENSION(:,:) :: INTERP_OUT + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EPS + REAL(KIND=R8), INTENT(IN), OPTIONAL :: EXTRAP + REAL(KIND=R8), INTENT(OUT), OPTIONAL, DIMENSION(:) :: RNORM + INTEGER, INTENT(IN), OPTIONAL :: IBUDGET + LOGICAL, INTENT(IN), OPTIONAL :: CHAIN + LOGICAL, INTENT(IN), OPTIONAL :: EXACT + INTEGER, INTENT(IN), OPTIONAL :: PMODE + END SUBROUTINE DELAUNAYSPARSEP + END INTERFACE + + IF (INTERP_IN_PRESENT) THEN + IF (INTERP_OUT_PRESENT) THEN + IF (EPS_PRESENT) THEN + IF (EXTRAP_PRESENT) THEN + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM) + END IF + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXTRAP=EXTRAP) + END IF + END IF + END IF + END IF + END IF + ELSE + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, RNORM=RNORM) + END IF + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EPS=EPS) + END IF + END IF + END IF + END IF + END IF + END IF + ELSE + IF (EXTRAP_PRESENT) THEN + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, RNORM=RNORM) + END IF + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXTRAP=EXTRAP) + END IF + END IF + END IF + END IF + END IF + ELSE + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, RNORM=RNORM, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, RNORM=RNORM, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, RNORM=RNORM, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, RNORM=RNORM) + END IF + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& INTERP_OUT=INTERP_OUT) + END IF + END IF + END IF + END IF + END IF + END IF + END IF + ELSE + IF (EPS_PRESENT) THEN + IF (EXTRAP_PRESENT) THEN + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM) + END IF + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXTRAP=EXTRAP) + END IF + END IF + END IF + END IF + END IF + ELSE + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, RNORM=RNORM, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, RNORM=RNORM, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, RNORM=RNORM, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, RNORM=RNORM) + END IF + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EPS=EPS) + END IF + END IF + END IF + END IF + END IF + END IF + ELSE + IF (EXTRAP_PRESENT) THEN + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, RNORM=RNORM, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, RNORM=RNORM) + END IF + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXTRAP=EXTRAP) + END IF + END IF + END IF + END IF + END IF + ELSE + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& RNORM=RNORM, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& RNORM=RNORM, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& RNORM=RNORM, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& RNORM=RNORM) + END IF + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN,& +& PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_IN=INTERP_IN) + END IF + END IF + END IF + END IF + END IF + END IF + END IF + END IF + ELSE + IF (INTERP_OUT_PRESENT) THEN + IF (EPS_PRESENT) THEN + IF (EXTRAP_PRESENT) THEN + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, RNORM=RNORM) + END IF + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXTRAP=EXTRAP) + END IF + END IF + END IF + END IF + END IF + ELSE + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, RNORM=RNORM, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, RNORM=RNORM, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, RNORM=RNORM, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, RNORM=RNORM) + END IF + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EPS=EPS) + END IF + END IF + END IF + END IF + END IF + END IF + ELSE + IF (EXTRAP_PRESENT) THEN + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, RNORM=RNORM, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, RNORM=RNORM, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, RNORM=RNORM, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, RNORM=RNORM) + END IF + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXTRAP=EXTRAP) + END IF + END IF + END IF + END IF + END IF + ELSE + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, RNORM=RNORM, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, RNORM=RNORM, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, RNORM=RNORM, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, RNORM=RNORM) + END IF + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, INTERP_OUT=INTERP_OU& +&T) + END IF + END IF + END IF + END IF + END IF + END IF + END IF + ELSE + IF (EPS_PRESENT) THEN + IF (EXTRAP_PRESENT) THEN + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, RNORM=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, RNORM=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, RNORM=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, RNORM=RNORM, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, RNORM=RNORM, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, RNORM=RNORM, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, RNORM=RNORM, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, RNORM=RNORM, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, RNORM=RNORM, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, RNORM=RNORM, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, RNORM=RNORM) + END IF + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXTRAP=EXTR& +&AP) + END IF + END IF + END IF + END IF + END IF + ELSE + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& +&, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& +&, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& +&, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& +&, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& +&, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& +&, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& +&, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& +&, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& +&, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& +&, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& +&, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& +&, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& +&, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& +&, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& +&, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, RNORM=RNORM& +&) + END IF + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBU& +&DGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBU& +&DGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBU& +&DGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBU& +&DGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBU& +&DGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBU& +&DGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBU& +&DGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, IBUDGET=IBU& +&DGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, CHAIN=CHAIN& +&, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, CHAIN=CHAIN& +&, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, CHAIN=CHAIN& +&, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, CHAIN=CHAIN& +&) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXACT=EXACT& +&, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, EXACT=EXACT& +&) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS, PMODE=PMODE& +&) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EPS=EPS) + END IF + END IF + END IF + END IF + END IF + END IF + ELSE + IF (EXTRAP_PRESENT) THEN + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& +&=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& +&=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& +&=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& +&=RNORM, IBUDGET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& +&=RNORM, IBUDGET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& +&=RNORM, IBUDGET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& +&=RNORM, IBUDGET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& +&=RNORM, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& +&=RNORM, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& +&=RNORM, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& +&=RNORM, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& +&=RNORM, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& +&=RNORM, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& +&=RNORM, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& +&=RNORM, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, RNORM& +&=RNORM) + END IF + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDG& +&ET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDG& +&ET=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDG& +&ET=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDG& +&ET=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDG& +&ET=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDG& +&ET=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDG& +&ET=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, IBUDG& +&ET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, CHAIN& +&=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, CHAIN& +&=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, CHAIN& +&=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, CHAIN& +&=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, EXACT& +&=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, EXACT& +&=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP, PMODE& +&=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXTRAP=EXTRAP) + END IF + END IF + END IF + END IF + END IF + ELSE + IF (RNORM_PRESENT) THEN + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET& +&=IBUDGET, CHAIN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET& +&=IBUDGET, CHAIN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET& +&=IBUDGET, CHAIN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET& +&=IBUDGET, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET& +&=IBUDGET, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET& +&=IBUDGET, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET& +&=IBUDGET, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, IBUDGET& +&=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, CHAIN=C& +&HAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, CHAIN=C& +&HAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, CHAIN=C& +&HAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, CHAIN=C& +&HAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, EXACT=E& +&XACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, EXACT=E& +&XACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM, PMODE=P& +&MODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, RNORM=RNORM) + END IF + END IF + END IF + END IF + ELSE + IF (IBUDGET_PRESENT) THEN + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, CHA& +&IN=CHAIN, EXACT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, CHA& +&IN=CHAIN, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, CHA& +&IN=CHAIN, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, CHA& +&IN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, EXA& +&CT=EXACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, EXA& +&CT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET, PMO& +&DE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, IBUDGET=IBUDGET) + END IF + END IF + END IF + ELSE + IF (CHAIN_PRESENT) THEN + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, CHAIN=CHAIN, EXACT=E& +&XACT, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, CHAIN=CHAIN, EXACT=E& +&XACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, CHAIN=CHAIN, PMODE=P& +&MODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, CHAIN=CHAIN) + END IF + END IF + ELSE + IF (EXACT_PRESENT) THEN + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXACT=EXACT, PMODE=P& +&MODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, EXACT=EXACT) + END IF + ELSE + IF (PMODE_PRESENT) THEN + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR, PMODE=PMODE) + ELSE + CALL DELAUNAYSPARSEP(D=D, N=N, PTS=PTS, M=M, Q=Q, SIMPS=SIMPS, WEIGHTS=WEIGHTS, IERR=IERR) + END IF + END IF + END IF + END IF + END IF + END IF + END IF + END IF + END IF +END SUBROUTINE C_DELAUNAYSPARSEP + diff --git a/python/delsparse_src/lapack.f b/python/delsparse_src/lapack.f new file mode 100755 index 0000000..3dff8b8 --- /dev/null +++ b/python/delsparse_src/lapack.f @@ -0,0 +1,4369 @@ + SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, +* -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER INB, INBMIN, IXOVER + PARAMETER( INB = 1, INBMIN = 2, IXOVER = 3 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, + $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN +* .. +* .. External Subroutines .. + EXTERNAL DGEQRF, DLAQP2, DLAQPS, DORMQR, DSWAP, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DNRM2 + EXTERNAL ILAENV, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE + IWS = 3*N + 1 + NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = 2*N + ( N + 1 )*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQP3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Move initial columns up front. +* + NFXD = 1 + DO 10 J = 1, N + IF( JPVT( J ).NE.0 ) THEN + IF( J.NE.NFXD ) THEN + CALL DSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 ) + JPVT( J ) = JPVT( NFXD ) + JPVT( NFXD ) = J + ELSE + JPVT( J ) = J + END IF + NFXD = NFXD + 1 + ELSE + JPVT( J ) = J + END IF + 10 CONTINUE + NFXD = NFXD - 1 +* +* Factorize fixed columns +* ======================= +* +* Compute the QR factorization of fixed columns and update +* remaining columns. +* + IF( NFXD.GT.0 ) THEN + NA = MIN( M, NFXD ) +*CC CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) + CALL DGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO ) + IWS = MAX( IWS, INT( WORK( 1 ) ) ) + IF( NA.LT.N ) THEN +*CC CALL DORM2R( 'LEFT', 'TRANSPOSE', M, N-NA, NA, A, LDA, +*CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) + CALL DORMQR( 'LEFT', 'TRANSPOSE', M, N-NA, NA, A, LDA, TAU, + $ A( 1, NA+1 ), LDA, WORK, LWORK, INFO ) + IWS = MAX( IWS, INT( WORK( 1 ) ) ) + END IF + END IF +* +* Factorize free columns +* ====================== +* + IF( NFXD.LT.MINMN ) THEN +* + SM = M - NFXD + SN = N - NFXD + SMINMN = MINMN - NFXD +* +* Determine the block size. +* + NB = ILAENV( INB, 'DGEQRF', ' ', SM, SN, -1, -1 ) + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked +* code. +* + NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', SM, SN, -1, + $ -1 ) ) +* +* + IF( NX.LT.SMINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + MINWS = 2*SN + ( SN+1 )*NB + IWS = MAX( IWS, MINWS ) + IF( LWORK.LT.MINWS ) THEN +* +* Not enough workspace to use optimal NB: Reduce NB and +* determine the minimum value of NB. +* + NB = ( LWORK-2*SN ) / ( SN+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', SM, N, + $ -1, -1 ) ) +* +* + END IF + END IF + END IF +* +* Initialize partial column norms. The first N elements of work +* store the exact column norms. +* + DO 20 J = NFXD + 1, N + WORK( J ) = DNRM2( SM, A( NFXD+1, J ), 1 ) + WORK( N+J ) = WORK( J ) + 20 CONTINUE +* + IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. + $ ( NX.LT.SMINMN ) ) THEN +* +* Use blocked code initially. +* + J = NFXD + 1 +* +* Compute factorization: while loop. +* +* + TOPBMN = MINMN - NX + 30 CONTINUE + IF( J.LE.TOPBMN ) THEN + JB = MIN( NB, TOPBMN-J+1 ) +* +* Factorize JB columns among columns J:N. +* + CALL DLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, + $ JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 ) +* + J = J + FJB + GO TO 30 + END IF + ELSE + J = NFXD + 1 + END IF +* +* Use unblocked code to factor the last or only block. +* +* + IF( J.LE.MINMN ) + $ CALL DLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), + $ TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ) ) +* + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of DGEQP3 +* + END + SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DGEQR2 computes a QR factorization of a real m by n matrix A: +* A = Q * R. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the m by n matrix A. +* On exit, the elements on and above the diagonal of the array +* contain the min(m,n) by n upper trapezoidal matrix R (R is +* upper triangular if m >= n); the elements below the diagonal, +* with the array TAU, represent the orthogonal matrix Q as a +* product of elementary reflectors (see Further Details). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) +* The scalar factors of the elementary reflectors (see Further +* Details). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further Details +* =============== +* +* The matrix Q is represented as a product of elementary reflectors +* +* Q = H(1) H(2) . . . H(k), where k = min(m,n). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**T +* +* where tau is a real scalar, and v is a real vector with +* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), +* and tau in TAU(i). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K + DOUBLE PRECISION AII +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQR2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = 1, K +* +* Generate elementary reflector H(i) to annihilate A(i+1:m,i) +* + CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, + $ TAU( I ) ) + IF( I.LT.N ) THEN +* +* Apply H(i) to A(i:m,i+1:n) from the left +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + A( I, I ) = AII + END IF + 10 CONTINUE + RETURN +* +* End of DGEQR2 +* + END + SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DGEQRF computes a QR factorization of a real M-by-N matrix A: +* A = Q * R. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the M-by-N matrix A. +* On exit, the elements on and above the diagonal of the array +* contain the min(M,N)-by-N upper trapezoidal matrix R (R is +* upper triangular if m >= n); the elements below the diagonal, +* with the array TAU, represent the orthogonal matrix Q as a +* product of min(m,n) elementary reflectors (see Further +* Details). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) +* The scalar factors of the elementary reflectors (see Further +* Details). +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension +* (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= max(1,N). +* For optimum performance LWORK >= N*NB, where NB is +* the optimal blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further Details +* =============== +* +* The matrix Q is represented as a product of elementary reflectors +* +* Q = H(1) H(2) . . . H(k), where k = min(m,n). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**T +* +* where tau is a real scalar, and v is a real vector with +* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), +* and tau in TAU(i). +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQRF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + K = MIN( M, N ) + IF( K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, + $ -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code initially +* + DO 10 I = 1, K - NX, NB + IB = MIN( K-I+1, NB ) +* +* Compute the QR factorization of the current block +* A(i:m,i:i+ib-1) +* + CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) + IF( I+IB.LE.N ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, + $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H**T to A(i:m,i+ib:n) from the left +* + CALL DLARFB( 'Left', 'Transpose', 'Forward', + $ 'Columnwise', M-I+1, N-I-IB+1, IB, + $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), + $ LDA, WORK( IB+1 ), LDWORK ) + END IF + 10 CONTINUE + ELSE + I = 1 + END IF +* +* Use unblocked code to factor the last or only block. +* + IF( I.LE.K ) + $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* + WORK( 1 ) = IWS + RETURN +* +* End of DGEQRF +* + END + SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DGETF2 computes an LU factorization of a general m-by-n matrix A +* using partial pivoting with row interchanges. +* +* The factorization has the form +* A = P * L * U +* where P is a permutation matrix, L is lower triangular with unit +* diagonal elements (lower trapezoidal if m > n), and U is upper +* triangular (upper trapezoidal if m < n). +* +* This is the right-looking Level 2 BLAS version of the algorithm. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the m by n matrix to be factored. +* On exit, the factors L and U from the factorization +* A = P*L*U; the unit diagonal elements of L are not stored. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* IPIV (output) INTEGER array, dimension (min(M,N)) +* The pivot indices; for 1 <= i <= min(M,N), row i of the +* matrix was interchanged with row IPIV(i). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -k, the k-th argument had an illegal value +* > 0: if INFO = k, U(k,k) is exactly zero. The factorization +* has been completed, but the factor U is exactly +* singular, and division by zero will occur if it is used +* to solve a system of equations. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION SFMIN + INTEGER I, J, JP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER IDAMAX + EXTERNAL DLAMCH, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL DGER, DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Compute machine safe minimum +* + SFMIN = DLAMCH('S') +* + DO 10 J = 1, MIN( M, N ) +* +* Find pivot and test for singularity. +* + JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) + IPIV( J ) = JP + IF( A( JP, J ).NE.ZERO ) THEN +* +* Apply the interchange to columns 1:N. +* + IF( JP.NE.J ) + $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) +* +* Compute elements J+1:M of J-th column. +* + IF( J.LT.M ) THEN + IF( ABS(A( J, J )) .GE. SFMIN ) THEN + CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) + ELSE + DO 20 I = 1, M-J + A( J+I, J ) = A( J+I, J ) / A( J, J ) + 20 CONTINUE + END IF + END IF +* + ELSE IF( INFO.EQ.0 ) THEN +* + INFO = J + END IF +* + IF( J.LT.MIN( M, N ) ) THEN +* +* Update trailing submatrix. +* + CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, + $ A( J+1, J+1 ), LDA ) + END IF + 10 CONTINUE + RETURN +* +* End of DGETF2 +* + END + SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DGETRF computes an LU factorization of a general M-by-N matrix A +* using partial pivoting with row interchanges. +* +* The factorization has the form +* A = P * L * U +* where P is a permutation matrix, L is lower triangular with unit +* diagonal elements (lower trapezoidal if m > n), and U is upper +* triangular (upper trapezoidal if m < n). +* +* This is the right-looking Level 3 BLAS version of the algorithm. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the M-by-N matrix to be factored. +* On exit, the factors L and U from the factorization +* A = P*L*U; the unit diagonal elements of L are not stored. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* IPIV (output) INTEGER array, dimension (min(M,N)) +* The pivot indices; for 1 <= i <= min(M,N), row i of the +* matrix was interchanged with row IPIV(i). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, U(i,i) is exactly zero. The factorization +* has been completed, but the factor U is exactly +* singular, and division by zero will occur if it is used +* to solve a system of equations. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IINFO, J, JB, NB +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN +* +* Use unblocked code. +* + CALL DGETF2( M, N, A, LDA, IPIV, INFO ) + ELSE +* +* Use blocked code. +* + DO 20 J = 1, MIN( M, N ), NB + JB = MIN( MIN( M, N )-J+1, NB ) +* +* Factor diagonal and subdiagonal blocks and test for exact +* singularity. +* + CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) +* +* Adjust INFO and the pivot indices. +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + J - 1 + DO 10 I = J, MIN( M, J+JB-1 ) + IPIV( I ) = J - 1 + IPIV( I ) + 10 CONTINUE +* +* Apply interchanges to columns 1:J-1. +* + CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) +* + IF( J+JB.LE.N ) THEN +* +* Apply interchanges to columns J+JB:N. +* + CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, + $ IPIV, 1 ) +* +* Compute block row of U. +* + CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, + $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), + $ LDA ) + IF( J+JB.LE.M ) THEN +* +* Update trailing submatrix. +* + CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, + $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, + $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), + $ LDA ) + END IF + END IF + 20 CONTINUE + END IF + RETURN +* +* End of DGETRF +* + END + SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* Purpose +* ======= +* +* DGETRS solves a system of linear equations +* A * X = B or A**T * X = B +* with a general N-by-N matrix A using the LU factorization computed +* by DGETRF. +* +* Arguments +* ========= +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T* X = B (Transpose) +* = 'C': A**T* X = B (Conjugate transpose = Transpose) +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrix B. NRHS >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The factors L and U from the factorization A = P*L*U +* as computed by DGETRF. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* IPIV (input) INTEGER array, dimension (N) +* The pivot indices from DGETRF; for 1<=i<=N, row i of the +* matrix was interchanged with row IPIV(i). +* +* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) +* On entry, the right hand side matrix B. +* On exit, the solution matrix X. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLASWP, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( NOTRAN ) THEN +* +* Solve A * X = B. +* +* Apply row interchanges to the right hand sides. +* + CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) +* +* Solve L*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve U*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, A, LDA, B, LDB ) + ELSE +* +* Solve A**T * X = B. +* +* Solve U**T *X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve L**T *X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, + $ A, LDA, B, LDB ) +* +* Apply row interchanges to the solution vectors. +* + CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) + END IF +* + RETURN +* +* End of DGETRS +* + END + DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y +* .. +* +* Purpose +* ======= +* +* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary +* overflow. +* +* Arguments +* ========= +* +* X (input) DOUBLE PRECISION +* Y (input) DOUBLE PRECISION +* X and Y specify the values x and y. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION W, XABS, YABS, Z +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + XABS = ABS( X ) + YABS = ABS( Y ) + W = MAX( XABS, YABS ) + Z = MIN( XABS, YABS ) + IF( Z.EQ.ZERO ) THEN + DLAPY2 = W + ELSE + DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) + END IF + RETURN +* +* End of DLAPY2 +* + END + SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, + $ WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, +* -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER LDA, M, N, OFFSET +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, MN, OFFPI, PVT + DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 +* .. +* .. Executable Statements .. +* + MN = MIN( M-OFFSET, N ) + TOL3Z = SQRT(DLAMCH('EPSILON')) +* +* Compute factorization. +* + DO 20 I = 1, MN +* + OFFPI = OFFSET + I +* +* Determine ith pivot column and swap if necessary. +* + PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 ) +* + IF( PVT.NE.I ) THEN + CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( I ) + JPVT( I ) = ITEMP + VN1( PVT ) = VN1( I ) + VN2( PVT ) = VN2( I ) + END IF +* +* Generate elementary reflector H(i). +* + IF( OFFPI.LT.M ) THEN + CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, + $ TAU( I ) ) + ELSE + CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) + END IF +* + IF( I.LT.N ) THEN +* +* Apply H(i)**T to A(offset+i:m,i+1:n) from the left. +* + AII = A( OFFPI, I ) + A( OFFPI, I ) = ONE + CALL DLARF( 'LEFT', M-OFFPI+1, N-I, A( OFFPI, I ), 1, + $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) + A( OFFPI, I ) = AII + END IF +* +* Update partial column norms. +* + DO 10 J = I + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following 4 lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN + IF( OFFPI.LT.M ) THEN + VN1( J ) = DNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) + VN2( J ) = VN1( J ) + ELSE + VN1( J ) = ZERO + VN2( J ) = ZERO + END IF + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + 10 CONTINUE +* + 20 CONTINUE +* + RETURN +* +* End of DLAQP2 +* + END + SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, + $ VN2, AUXV, F, LDF ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, +* -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER KB, LDA, LDF, M, N, NB, OFFSET +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), + $ VN1( * ), VN2( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK + DOUBLE PRECISION AKK, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, NINT, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 +* .. +* .. Executable Statements .. +* + LASTRK = MIN( M, N+OFFSET ) + LSTICC = 0 + K = 0 + TOL3Z = SQRT(DLAMCH('EPSILON')) +* +* Beginning of while loop. +* + 10 CONTINUE + IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN + K = K + 1 + RK = OFFSET + K +* +* Determine ith pivot column and swap if necessary +* + PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) + IF( PVT.NE.K ) THEN + CALL DSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 ) + CALL DSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( K ) + JPVT( K ) = ITEMP + VN1( PVT ) = VN1( K ) + VN2( PVT ) = VN2( K ) + END IF +* +* Apply previous Householder reflectors to column K: +* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**T. +* + IF( K.GT.1 ) THEN + CALL DGEMV( 'NO TRANSPOSE', M-RK+1, K-1, -ONE, A( RK, 1 ), + $ LDA, F( K, 1 ), LDF, ONE, A( RK, K ), 1 ) + END IF +* +* Generate elementary reflector H(k). +* + IF( RK.LT.M ) THEN + CALL DLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) + ELSE + CALL DLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) + END IF +* + AKK = A( RK, K ) + A( RK, K ) = ONE +* +* Compute Kth column of F: +* +* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**T*A(RK:M,K). +* + IF( K.LT.N ) THEN + CALL DGEMV( 'TRANSPOSE', M-RK+1, N-K, TAU( K ), + $ A( RK, K+1 ), LDA, A( RK, K ), 1, ZERO, + $ F( K+1, K ), 1 ) + END IF +* +* Padding F(1:K,K) with zeros. +* + DO 20 J = 1, K + F( J, K ) = ZERO + 20 CONTINUE +* +* Incremental updating of F: +* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**T +* *A(RK:M,K). +* + IF( K.GT.1 ) THEN + CALL DGEMV( 'TRANSPOSE', M-RK+1, K-1, -TAU( K ), A( RK, 1 ), + $ LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 ) +* + CALL DGEMV( 'NO TRANSPOSE', N, K-1, ONE, F( 1, 1 ), LDF, + $ AUXV( 1 ), 1, ONE, F( 1, K ), 1 ) + END IF +* +* Update the current row of A: +* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**T. +* + IF( K.LT.N ) THEN + CALL DGEMV( 'NO TRANSPOSE', N-K, K, -ONE, F( K+1, 1 ), LDF, + $ A( RK, 1 ), LDA, ONE, A( RK, K+1 ), LDA ) + END IF +* +* Update partial column norms. +* + IF( RK.LT.LASTRK ) THEN + DO 30 J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following 4 lines follow from the analysis +* in +* Lapack Working Note 176. +* + TEMP = ABS( A( RK, J ) ) / VN1( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN + VN2( J ) = DBLE( LSTICC ) + LSTICC = J + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE + END IF +* + A( RK, K ) = AKK +* +* End of while loop. +* + GO TO 10 + END IF + KB = K + RK = OFFSET + KB +* +* Apply the block reflector to the rest of the matrix: +* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - +* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**T. +* + IF( KB.LT.MIN( N, M-OFFSET ) ) THEN + CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M-RK, N-KB, KB, -ONE, + $ A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, + $ A( RK+1, KB+1 ), LDA ) + END IF +* +* Recomputation of difficult columns. +* + 40 CONTINUE + IF( LSTICC.GT.0 ) THEN + ITEMP = NINT( VN2( LSTICC ) ) + VN1( LSTICC ) = DNRM2( M-RK, A( RK+1, LSTICC ), 1 ) +* +* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* SNRM2 does not fail on vectors with norm below the value of +* SQRT(DLAMCH('S')) +* + VN2( LSTICC ) = VN1( LSTICC ) + LSTICC = ITEMP + GO TO 40 + END IF +* + RETURN +* +* End of DLAQPS +* + END + SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DLARF applies a real elementary reflector H to a real m by n matrix +* C, from either the left or the right. H is represented in the form +* +* H = I - tau * v * v**T +* +* where tau is a real scalar and v is a real vector. +* +* If tau = 0, then H is taken to be the unit matrix. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': form H * C +* = 'R': form C * H +* +* M (input) INTEGER +* The number of rows of the matrix C. +* +* N (input) INTEGER +* The number of columns of the matrix C. +* +* V (input) DOUBLE PRECISION array, dimension +* (1 + (M-1)*abs(INCV)) if SIDE = 'L' +* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +* The vector v in the representation of H. V is not used if +* TAU = 0. +* +* INCV (input) INTEGER +* The increment between elements of v. INCV <> 0. +* +* TAU (input) DOUBLE PRECISION +* The value tau in the representation of H. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m by n matrix C. +* On exit, C is overwritten by the matrix H * C if SIDE = 'L', +* or C * H if SIDE = 'R'. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension +* (N) if SIDE = 'L' +* or (M) if SIDE = 'R' +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILADLR, ILADLC + EXTERNAL LSAME, ILADLR, ILADLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 0 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V. + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILADLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILADLR(M, LASTV, C, LDC) + END IF + END IF +! Note that lastc.eq.0 renders the BLAS operations null; no special +! case is needed at this level. + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) +* + CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, + $ ZERO, WORK, 1 ) +* +* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * +* w(1:lastc,1)**T +* + CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) +* + CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, + $ V, INCV, ZERO, WORK, 1 ) +* +* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * +* v(1:lastv,1)**T +* + CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) + END IF + END IF + RETURN +* +* End of DLARF +* + END + SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, + $ T, LDT, C, LDC, WORK, LDWORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), + $ WORK( LDWORK, * ) +* .. +* +* Purpose +* ======= +* +* DLARFB applies a real block reflector H or its transpose H**T to a +* real m by n matrix C, from either the left or the right. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply H or H**T from the Left +* = 'R': apply H or H**T from the Right +* +* TRANS (input) CHARACTER*1 +* = 'N': apply H (No transpose) +* = 'T': apply H**T (Transpose) +* +* DIRECT (input) CHARACTER*1 +* Indicates how H is formed from a product of elementary +* reflectors +* = 'F': H = H(1) H(2) . . . H(k) (Forward) +* = 'B': H = H(k) . . . H(2) H(1) (Backward) +* +* STOREV (input) CHARACTER*1 +* Indicates how the vectors which define the elementary +* reflectors are stored: +* = 'C': Columnwise +* = 'R': Rowwise +* +* M (input) INTEGER +* The number of rows of the matrix C. +* +* N (input) INTEGER +* The number of columns of the matrix C. +* +* K (input) INTEGER +* The order of the matrix T (= the number of elementary +* reflectors whose product defines the block reflector). +* +* V (input) DOUBLE PRECISION array, dimension +* (LDV,K) if STOREV = 'C' +* (LDV,M) if STOREV = 'R' and SIDE = 'L' +* (LDV,N) if STOREV = 'R' and SIDE = 'R' +* The matrix V. See Further Details. +* +* LDV (input) INTEGER +* The leading dimension of the array V. +* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); +* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); +* if STOREV = 'R', LDV >= K. +* +* T (input) DOUBLE PRECISION array, dimension (LDT,K) +* The triangular k by k matrix T in the representation of the +* block reflector. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= K. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m by n matrix C. +* On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) +* +* LDWORK (input) INTEGER +* The leading dimension of the array WORK. +* If SIDE = 'L', LDWORK >= max(1,N); +* if SIDE = 'R', LDWORK >= max(1,M). +* +* Further Details +* =============== +* +* The shape of the matrix V and the storage of the vectors which define +* the H(i) is best illustrated by the following example with n = 5 and +* k = 3. The elements equal to 1 are not stored; the corresponding +* array elements are modified but restored on exit. The rest of the +* array is not used. +* +* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +* +* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +* ( v1 1 ) ( 1 v2 v2 v2 ) +* ( v1 v2 1 ) ( 1 v3 v3 ) +* ( v1 v2 v3 ) +* ( v1 v2 v3 ) +* +* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +* +* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +* ( v1 v2 v3 ) ( v2 v2 v2 1 ) +* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +* ( 1 v3 ) +* ( 1 ) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + CHARACTER TRANST + INTEGER I, J, LASTV, LASTC +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILADLR, ILADLC + EXTERNAL LSAME, ILADLR, ILADLC +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DTRMM +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* + IF( LSAME( TRANS, 'N' ) ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* + IF( LSAME( STOREV, 'C' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 ) (first K rows) +* ( V2 ) +* where V1 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in +* WORK) +* +* W := C1**T +* + DO 10 J = 1, K + CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 10 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2**T *V2 +* + CALL DGEMM( 'Transpose', 'No transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**T +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - V2 * W**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTV-K, LASTC, K, + $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**T +* + DO 30 J = 1, K + DO 20 I = 1, LASTC + C( J, I ) = C( J, I ) - WORK( I, J ) + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C1 +* + DO 40 J = 1, K + CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + 40 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2 * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**T +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - W * V2**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, LASTV-K, K, + $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 60 J = 1, K + DO 50 I = 1, LASTC + C( I, J ) = C( I, J ) - WORK( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + ELSE +* +* Let V = ( V1 ) +* ( V2 ) (last K rows) +* where V2 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in +* WORK) +* +* W := C2**T +* + DO 70 J = 1, K + CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, + $ WORK( 1, J ), 1 ) + 70 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1**T*V1 +* + CALL DGEMM( 'Transpose', 'No transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**T +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - V1 * W**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) + END IF +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W**T +* + DO 90 J = 1, K + DO 80 I = 1, LASTC + C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C2 +* + DO 100 J = 1, K + CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 100 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1 * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**T +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - W * V1**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, + $ ONE, C, LDC ) + END IF +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W +* + DO 120 J = 1, K + DO 110 I = 1, LASTC + C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) + 110 CONTINUE + 120 CONTINUE + END IF + END IF +* + ELSE IF( LSAME( STOREV, 'R' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 V2 ) (V1: first K columns) +* where V1 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) +* (stored in WORK) +* +* W := C1**T +* + DO 130 J = 1, K + CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 130 CONTINUE +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2**T*V2**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**T * W**T +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - V2**T * W**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTV-K, LASTC, K, + $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, + $ ONE, C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**T +* + DO 150 J = 1, K + DO 140 I = 1, LASTC + C( J, I ) = C( J, I ) - WORK( I, J ) + 140 CONTINUE + 150 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) +* +* W := C1 +* + DO 160 J = 1, K + CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + 160 CONTINUE +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2 * V2**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - W * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, LASTV-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, + $ ONE, C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 180 J = 1, K + DO 170 I = 1, LASTC + C( I, J ) = C( I, J ) - WORK( I, J ) + 170 CONTINUE + 180 CONTINUE +* + END IF +* + ELSE +* +* Let V = ( V1 V2 ) (V2: last K columns) +* where V2 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) +* (stored in WORK) +* +* W := C2**T +* + DO 190 J = 1, K + CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, + $ WORK( 1, J ), 1 ) + 190 CONTINUE +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1**T * V1**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**T * W**T +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - V1**T * W**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W**T +* + DO 210 J = 1, K + DO 200 I = 1, LASTC + C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) + 200 CONTINUE + 210 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) +* +* W := C2 +* + DO 220 J = 1, K + CALL DCOPY( LASTC, C( 1, LASTV-K+J ), 1, + $ WORK( 1, J ), 1 ) + 220 CONTINUE +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1 * V1**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - W * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, + $ ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 240 J = 1, K + DO 230 I = 1, LASTC + C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) + 230 CONTINUE + 240 CONTINUE +* + END IF +* + END IF + END IF +* + RETURN +* +* End of DLARFB +* + END + SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION ALPHA, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* Purpose +* ======= +* +* DLARFG generates a real elementary reflector H of order n, such +* that +* +* H * ( alpha ) = ( beta ), H**T * H = I. +* ( x ) ( 0 ) +* +* where alpha and beta are scalars, and x is an (n-1)-element real +* vector. H is represented in the form +* +* H = I - tau * ( 1 ) * ( 1 v**T ) , +* ( v ) +* +* where tau is a real scalar and v is a real (n-1)-element +* vector. +* +* If the elements of x are all zero, then tau = 0 and H is taken to be +* the unit matrix. +* +* Otherwise 1 <= tau <= 2. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the elementary reflector. +* +* ALPHA (input/output) DOUBLE PRECISION +* On entry, the value alpha. +* On exit, it is overwritten with the value beta. +* +* X (input/output) DOUBLE PRECISION array, dimension +* (1+(N-2)*abs(INCX)) +* On entry, the vector x. +* On exit, it is overwritten with the vector v. +* +* INCX (input) INTEGER +* The increment between elements of X. INCX > 0. +* +* TAU (output) DOUBLE PRECISION +* The value tau. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER J, KNT + DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 + EXTERNAL DLAMCH, DLAPY2, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN +* .. +* .. External Subroutines .. + EXTERNAL DSCAL +* .. +* .. Executable Statements .. +* + IF( N.LE.1 ) THEN + TAU = ZERO + RETURN + END IF +* + XNORM = DNRM2( N-1, X, INCX ) +* + IF( XNORM.EQ.ZERO ) THEN +* +* H = I +* + TAU = ZERO + ELSE +* +* general case +* + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) + KNT = 0 + IF( ABS( BETA ).LT.SAFMIN ) THEN +* +* XNORM, BETA may be inaccurate; scale X and recompute them +* + RSAFMN = ONE / SAFMIN + 10 CONTINUE + KNT = KNT + 1 + CALL DSCAL( N-1, RSAFMN, X, INCX ) + BETA = BETA*RSAFMN + ALPHA = ALPHA*RSAFMN + IF( ABS( BETA ).LT.SAFMIN ) + $ GO TO 10 +* +* New BETA is at most 1, at least SAFMIN +* + XNORM = DNRM2( N-1, X, INCX ) + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + END IF + TAU = ( BETA-ALPHA ) / BETA + CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) +* +* If ALPHA is subnormal, it may lose relative accuracy +* + DO 20 J = 1, KNT + BETA = BETA*SAFMIN + 20 CONTINUE + ALPHA = BETA + END IF +* + RETURN +* +* End of DLARFG +* + END + SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* Purpose +* ======= +* +* DLARFT forms the triangular factor T of a real block reflector H +* of order n, which is defined as a product of k elementary reflectors. +* +* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; +* +* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. +* +* If STOREV = 'C', the vector which defines the elementary reflector +* H(i) is stored in the i-th column of the array V, and +* +* H = I - V * T * V**T +* +* If STOREV = 'R', the vector which defines the elementary reflector +* H(i) is stored in the i-th row of the array V, and +* +* H = I - V**T * T * V +* +* Arguments +* ========= +* +* DIRECT (input) CHARACTER*1 +* Specifies the order in which the elementary reflectors are +* multiplied to form the block reflector: +* = 'F': H = H(1) H(2) . . . H(k) (Forward) +* = 'B': H = H(k) . . . H(2) H(1) (Backward) +* +* STOREV (input) CHARACTER*1 +* Specifies how the vectors which define the elementary +* reflectors are stored (see also Further Details): +* = 'C': columnwise +* = 'R': rowwise +* +* N (input) INTEGER +* The order of the block reflector H. N >= 0. +* +* K (input) INTEGER +* The order of the triangular factor T (= the number of +* elementary reflectors). K >= 1. +* +* V (input/output) DOUBLE PRECISION array, dimension +* (LDV,K) if STOREV = 'C' +* (LDV,N) if STOREV = 'R' +* The matrix V. See further details. +* +* LDV (input) INTEGER +* The leading dimension of the array V. +* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i). +* +* T (output) DOUBLE PRECISION array, dimension (LDT,K) +* The k by k triangular factor T of the block reflector. +* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is +* lower triangular. The rest of the array is not used. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= K. +* +* Further Details +* =============== +* +* The shape of the matrix V and the storage of the vectors which define +* the H(i) is best illustrated by the following example with n = 5 and +* k = 3. The elements equal to 1 are not stored; the corresponding +* array elements are modified but restored on exit. The rest of the +* array is not used. +* +* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +* +* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +* ( v1 1 ) ( 1 v2 v2 v2 ) +* ( v1 v2 1 ) ( 1 v3 v3 ) +* ( v1 v2 v3 ) +* ( v1 v2 v3 ) +* +* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +* +* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +* ( v1 v2 v3 ) ( v2 v2 v2 1 ) +* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +* ( 1 v3 ) +* ( 1 ) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, PREVLASTV, LASTV + DOUBLE PRECISION VII +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DTRMV +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( LSAME( DIRECT, 'F' ) ) THEN + PREVLASTV = N + DO 20 I = 1, K + PREVLASTV = MAX( I, PREVLASTV ) + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 10 J = 1, I + T( J, I ) = ZERO + 10 CONTINUE + ELSE +* +* general case +* + VII = V( I, I ) + V( I, I ) = ONE + IF( LSAME( STOREV, 'C' ) ) THEN +! Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) +* + CALL DGEMV( 'Transpose', J-I+1, I-1, -TAU( I ), + $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, + $ T( 1, I ), 1 ) + ELSE +! Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T +* + CALL DGEMV( 'No transpose', I-1, J-I+1, -TAU( I ), + $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, + $ T( 1, I ), 1 ) + END IF + V( I, I ) = VII +* +* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) +* + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, + $ LDT, T( 1, I ), 1 ) + T( I, I ) = TAU( I ) + IF( I.GT.1 ) THEN + PREVLASTV = MAX( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + 20 CONTINUE + ELSE + PREVLASTV = 1 + DO 40 I = K, 1, -1 + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 30 J = I, K + T( J, I ) = ZERO + 30 CONTINUE + ELSE +* +* general case +* + IF( I.LT.K ) THEN + IF( LSAME( STOREV, 'C' ) ) THEN + VII = V( N-K+I, I ) + V( N-K+I, I ) = ONE +! Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) := +* - tau(i) * V(j:n-k+i,i+1:k)**T * +* V(j:n-k+i,i) +* + CALL DGEMV( 'Transpose', N-K+I-J+1, K-I, -TAU( I ), + $ V( J, I+1 ), LDV, V( J, I ), 1, ZERO, + $ T( I+1, I ), 1 ) + V( N-K+I, I ) = VII + ELSE + VII = V( I, N-K+I ) + V( I, N-K+I ) = ONE +! Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) := +* - tau(i) * V(i+1:k,j:n-k+i) * +* V(i,j:n-k+i)**T +* + CALL DGEMV( 'No transpose', K-I, N-K+I-J+1, + $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, + $ ZERO, T( I+1, I ), 1 ) + V( I, N-K+I ) = VII + END IF +* +* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) +* + CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, + $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + IF( I.GT.1 ) THEN + PREVLASTV = MIN( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + T( I, I ) = TAU( I ) + END IF + 40 CONTINUE + END IF + RETURN +* +* End of DLARFT +* + END + SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, K1, K2, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DLASWP performs a series of row interchanges on the matrix A. +* One row interchange is initiated for each of rows K1 through K2 of A. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The number of columns of the matrix A. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the matrix of column dimension N to which the row +* interchanges will be applied. +* On exit, the permuted matrix. +* +* LDA (input) INTEGER +* The leading dimension of the array A. +* +* K1 (input) INTEGER +* The first element of IPIV for which a row interchange will +* be done. +* +* K2 (input) INTEGER +* The last element of IPIV for which a row interchange will +* be done. +* +* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) +* The vector of pivot indices. Only the elements in positions +* K1 through K2 of IPIV are accessed. +* IPIV(K) = L implies rows K and L are to be interchanged. +* +* INCX (input) INTEGER +* The increment between successive values of IPIV. If IPIV +* is negative, the pivots are applied in reverse order. +* +* Further Details +* =============== +* +* Modified by +* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 + DOUBLE PRECISION TEMP +* .. +* .. Executable Statements .. +* +* Interchange row I with row IPIV(I) for each of rows K1 through K2. +* + IF( INCX.GT.0 ) THEN + IX0 = K1 + I1 = K1 + I2 = K2 + INC = 1 + ELSE IF( INCX.LT.0 ) THEN + IX0 = 1 + ( 1-K2 )*INCX + I1 = K2 + I2 = K1 + INC = -1 + ELSE + RETURN + END IF +* + N32 = ( N / 32 )*32 + IF( N32.NE.0 ) THEN + DO 30 J = 1, N32, 32 + IX = IX0 + DO 20 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 10 K = J, J + 31 + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 10 CONTINUE + END IF + IX = IX + INCX + 20 CONTINUE + 30 CONTINUE + END IF + IF( N32.NE.N ) THEN + N32 = N32 + 1 + IX = IX0 + DO 50 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 40 K = N32, N + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 40 CONTINUE + END IF + IX = IX + INCX + 50 CONTINUE + END IF +* + RETURN +* +* End of DLASWP +* + END + SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORM2R overwrites the general real m by n matrix C with +* +* Q * C if SIDE = 'L' and TRANS = 'N', or +* +* Q**T* C if SIDE = 'L' and TRANS = 'T', or +* +* C * Q if SIDE = 'R' and TRANS = 'N', or +* +* C * Q**T if SIDE = 'R' and TRANS = 'T', +* +* where Q is a real orthogonal matrix defined as the product of k +* elementary reflectors +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n +* if SIDE = 'R'. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply Q or Q**T from the Left +* = 'R': apply Q or Q**T from the Right +* +* TRANS (input) CHARACTER*1 +* = 'N': apply Q (No transpose) +* = 'T': apply Q**T (Transpose) +* +* M (input) INTEGER +* The number of rows of the matrix C. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix C. N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines +* the matrix Q. +* If SIDE = 'L', M >= K >= 0; +* if SIDE = 'R', N >= K >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,K) +* The i-th column must contain the vector which defines the +* elementary reflector H(i), for i = 1,2,...,k, as returned by +* DGEQRF in the first k columns of its array argument A. +* A is modified by the routine but restored on exit. +* +* LDA (input) INTEGER +* The leading dimension of the array A. +* If SIDE = 'L', LDA >= max(1,M); +* if SIDE = 'R', LDA >= max(1,N). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DGEQRF. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m by n matrix C. +* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension +* (N) if SIDE = 'L', +* (M) if SIDE = 'R' +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + DOUBLE PRECISION AII +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORM2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) + $ THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), + $ LDC, WORK ) + A( I, I ) = AII + 10 CONTINUE + RETURN +* +* End of DORM2R +* + END + SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORMQR overwrites the general real M-by-N matrix C with +* +* SIDE = 'L' SIDE = 'R' +* TRANS = 'N': Q * C C * Q +* TRANS = 'T': Q**T * C C * Q**T +* +* where Q is a real orthogonal matrix defined as the product of k +* elementary reflectors +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N +* if SIDE = 'R'. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply Q or Q**T from the Left; +* = 'R': apply Q or Q**T from the Right. +* +* TRANS (input) CHARACTER*1 +* = 'N': No transpose, apply Q; +* = 'T': Transpose, apply Q**T. +* +* M (input) INTEGER +* The number of rows of the matrix C. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix C. N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines +* the matrix Q. +* If SIDE = 'L', M >= K >= 0; +* if SIDE = 'R', N >= K >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,K) +* The i-th column must contain the vector which defines the +* elementary reflector H(i), for i = 1,2,...,k, as returned by +* DGEQRF in the first k columns of its array argument A. +* A is modified by the routine but restored on exit. +* +* LDA (input) INTEGER +* The leading dimension of the array A. +* If SIDE = 'L', LDA >= max(1,M); +* if SIDE = 'R', LDA >= max(1,N). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DGEQRF. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the M-by-N matrix C. +* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension +* (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. +* If SIDE = 'L', LWORK >= max(1,N); +* if SIDE = 'R', LWORK >= max(1,M). +* For optimum performance LWORK >= N*NB if SIDE = 'L', and +* LWORK >= M*NB if SIDE = 'R', where NB is the optimal +* blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + DOUBLE PRECISION T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. NB may be at most NBMAX, where NBMAX +* is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), + $ LDA, TAU( I ), T, LDT ) + IF( LEFT ) THEN +* +* H or H**T is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H or H**T is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H or H**T +* + CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, + $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, + $ WORK, LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMQR +* + END + DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* -- LAPACK auxiliary routine (version 3.3.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* Based on LAPACK DLAMCH but with Fortran 95 query functions +* See: http://www.cs.utk.edu/~luszczek/lapack/lamch.html +* and +* http://www.netlib.org/lapack-dev/lapack-coding/program-style.html#id2537289 +* July 2010 +* +* .. Scalar Arguments .. + CHARACTER CMACH +* .. +* +* Purpose +* ======= +* +* DLAMCH determines double precision machine parameters. +* +* Arguments +* ========= +* +* CMACH (input) CHARACTER*1 +* Specifies the value to be returned by DLAMCH: +* = 'E' or 'e', DLAMCH := eps +* = 'S' or 's , DLAMCH := sfmin +* = 'B' or 'b', DLAMCH := base +* = 'P' or 'p', DLAMCH := eps*base +* = 'N' or 'n', DLAMCH := t +* = 'R' or 'r', DLAMCH := rnd +* = 'M' or 'm', DLAMCH := emin +* = 'U' or 'u', DLAMCH := rmin +* = 'L' or 'l', DLAMCH := emax +* = 'O' or 'o', DLAMCH := rmax +* +* where +* +* eps = relative machine precision +* sfmin = safe minimum, such that 1/sfmin does not overflow +* base = base of the machine +* prec = eps*base +* t = number of (base) digits in the mantissa +* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise +* emin = minimum exponent before (gradual) underflow +* rmin = underflow threshold - base**(emin-1) +* emax = largest exponent before overflow +* rmax = overflow threshold - (base**emax)*(1-eps) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, + $ MINEXPONENT, RADIX, TINY +* .. +* .. Executable Statements .. +* +* +* Assume rounding, not chopping. Always. +* + RND = ONE +* + IF( ONE.EQ.RND ) THEN + EPS = EPSILON(ZERO) * 0.5 + ELSE + EPS = EPSILON(ZERO) + END IF +* + IF( LSAME( CMACH, 'E' ) ) THEN + RMACH = EPS + ELSE IF( LSAME( CMACH, 'S' ) ) THEN + SFMIN = TINY(ZERO) + SMALL = ONE / HUGE(ZERO) + IF( SMALL.GE.SFMIN ) THEN +* +* Use SMALL plus a bit, to avoid the possibility of rounding +* causing overflow when computing 1/sfmin. +* + SFMIN = SMALL*( ONE+EPS ) + END IF + RMACH = SFMIN + ELSE IF( LSAME( CMACH, 'B' ) ) THEN + RMACH = RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'P' ) ) THEN + RMACH = EPS * RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'N' ) ) THEN + RMACH = DIGITS(ZERO) + ELSE IF( LSAME( CMACH, 'R' ) ) THEN + RMACH = RND + ELSE IF( LSAME( CMACH, 'M' ) ) THEN + RMACH = MINEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'U' ) ) THEN + RMACH = tiny(zero) + ELSE IF( LSAME( CMACH, 'L' ) ) THEN + RMACH = MAXEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'O' ) ) THEN + RMACH = HUGE(ZERO) + ELSE + RMACH = ZERO + END IF +* + DLAMCH = RMACH + RETURN +* +* End of DLAMCH +* + END +************************************************************************ +* + INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER ISPEC + REAL ONE, ZERO +* .. +* +* Purpose +* ======= +* +* IEEECK is called from the ILAENV to verify that Infinity and +* possibly NaN arithmetic is safe (i.e. will not trap). +* +* Arguments +* ========= +* +* ISPEC (input) INTEGER +* Specifies whether to test just for inifinity arithmetic +* or whether to test for infinity and NaN arithmetic. +* = 0: Verify infinity arithmetic only. +* = 1: Verify infinity and NaN arithmetic. +* +* ZERO (input) REAL +* Must contain the value 0.0 +* This is passed to prevent the compiler from optimizing +* away this code. +* +* ONE (input) REAL +* Must contain the value 1.0 +* This is passed to prevent the compiler from optimizing +* away this code. +* +* RETURN VALUE: INTEGER +* = 0: Arithmetic failed to produce the correct answers +* = 1: Arithmetic produced the correct answers +* +* ===================================================================== +* +* .. Local Scalars .. + REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, + $ NEGZRO, NEWZRO, POSINF +* .. +* .. Executable Statements .. + IEEECK = 1 +* + POSINF = ONE / ZERO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = -ONE / ZERO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGZRO = ONE / ( NEGINF+ONE ) + IF( NEGZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = ONE / NEGZRO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEWZRO = NEGZRO + ZERO + IF( NEWZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = ONE / NEWZRO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = NEGINF*POSINF + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = POSINF*POSINF + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* +* +* +* +* Return if we were only asked to check infinity arithmetic +* + IF( ISPEC.EQ.0 ) + $ RETURN +* + NAN1 = POSINF + NEGINF +* + NAN2 = POSINF / NEGINF +* + NAN3 = POSINF / POSINF +* + NAN4 = POSINF*ZERO +* + NAN5 = NEGINF*NEGZRO +* + NAN6 = NAN5*ZERO +* + IF( NAN1.EQ.NAN1 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN2.EQ.NAN2 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN3.EQ.NAN3 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN4.EQ.NAN4 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN5.EQ.NAN5 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN6.EQ.NAN6 ) THEN + IEEECK = 0 + RETURN + END IF +* + RETURN + END + INTEGER FUNCTION ILADLC( M, N, A, LDA ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.2.2) -- +* +* -- June 2010 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* ILADLC scans A for its last non-zero column. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. +* +* N (input) INTEGER +* The number of columns of the matrix A. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The m by n matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( N.EQ.0 ) THEN + ILADLC = N + ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILADLC = N + ELSE +* Now scan each column from the end, returning with the first +* non-zero. + DO ILADLC = N, 1, -1 + DO I = 1, M + IF( A(I, ILADLC).NE.ZERO ) RETURN + END DO + END DO + END IF + RETURN + END + INTEGER FUNCTION ILADLR( M, N, A, LDA ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* ILADLR scans A for its last non-zero row. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. +* +* N (input) INTEGER +* The number of columns of the matrix A. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The m by n matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( M.EQ.0 ) THEN + ILADLR = M + ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILADLR = M + ELSE +* Scan up each column tracking the last zero row seen. + ILADLR = 0 + DO J = 1, N + I=M + DO WHILE ((A(I,J).NE.ZERO).AND.(I.GE.1)) + I=I-1 + ENDDO + ILADLR = MAX( ILADLR, I ) + END DO + END IF + RETURN + END + INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* -- LAPACK auxiliary routine (version 3.2.1) -- +* +* -- April 2009 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* Purpose +* ======= +* +* ILAENV is called from the LAPACK routines to choose problem-dependent +* parameters for the local environment. See ISPEC for a description of +* the parameters. +* +* ILAENV returns an INTEGER +* if ILAENV >= 0: ILAENV returns the value of the parameter specified +* by ISPEC +* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal +* value. +* +* This version provides a set of parameters which should give good, +* but not optimal, performance on many of the currently available +* computers. Users are encouraged to modify this subroutine to set +* the tuning parameters for their particular machine using the option +* and problem size information in the arguments. +* +* This routine will not function correctly if it is converted to all +* lower case. Converting it to all upper case is allowed. +* +* Arguments +* ========= +* +* ISPEC (input) INTEGER +* Specifies the parameter to be returned as the value of +* ILAENV. +* = 1: the optimal blocksize; if this value is 1, an unblocked +* algorithm will give the best performance. +* = 2: the minimum block size for which the block routine +* should be used; if the usable block size is less than +* this value, an unblocked routine should be used. +* = 3: the crossover point (in a block routine, for N less +* than this value, an unblocked routine should be used) +* = 4: the number of shifts, used in the nonsymmetric +* eigenvalue routines (DEPRECATED) +* = 5: the minimum column dimension for blocking to be used; +* rectangular blocks must have dimension at least k by m, +* where k is given by ILAENV(2,...) and m by ILAENV(5,...) +* = 6: the crossover point for the SVD (when reducing an m by n +* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds +* this value, a QR factorization is used first to reduce +* the matrix to a triangular form.) +* = 7: the number of processors +* = 8: the crossover point for the multishift QR method +* for nonsymmetric eigenvalue problems (DEPRECATED) +* = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* =10: ieee NaN arithmetic can be trusted not to trap +* =11: infinity arithmetic can be trusted not to trap +* 12 <= ISPEC <= 16: +* xHSEQR or one of its subroutines, +* see IPARMQ for detailed explanation +* +* NAME (input) CHARACTER*(*) +* The name of the calling subroutine, in either upper case or +* lower case. +* +* OPTS (input) CHARACTER*(*) +* The character options to the subroutine NAME, concatenated +* into a single character string. For example, UPLO = 'U', +* TRANS = 'T', and DIAG = 'N' for a triangular routine would +* be specified as OPTS = 'UTN'. +* +* N1 (input) INTEGER +* N2 (input) INTEGER +* N3 (input) INTEGER +* N4 (input) INTEGER +* Problem dimensions for the subroutine NAME; these may not all +* be required. +* +* Further Details +* =============== +* +* The following conventions have been used when calling ILAENV from the +* LAPACK routines: +* 1) OPTS is a concatenation of all of the character options to +* subroutine NAME, in the same order that they appear in the +* argument list for NAME, even if they are not used in determining +* the value of the parameter specified by ISPEC. +* 2) The problem dimensions N1, N2, N3, N4 are specified in the order +* that they appear in the argument list for NAME. N1 is used +* first, N2 second, and so on, and unused problem dimensions are +* passed a value of -1. +* 3) The parameter value returned by ILAENV is checked for validity in +* the calling subroutine. For example, ILAENV is used to retrieve +* the optimal blocksize for STRTRI as follows: +* +* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) +* IF( NB.LE.1 ) NB = MAX( 1, N ) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IC, IZ, NB, NBMIN, NX + LOGICAL CNAME, SNAME + CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 +* .. +* .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, INT, MIN, REAL +* .. +* .. External Functions .. + INTEGER IEEECK, IPARMQ + EXTERNAL IEEECK, IPARMQ +* .. +* .. Executable Statements .. +* + GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, + $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC +* +* Invalid value for ISPEC +* + ILAENV = -1 + RETURN +* + 10 CONTINUE +* +* Convert NAME to upper case if the first character is lower case. +* + ILAENV = 1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 20 CONTINUE + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + 30 CONTINUE + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 40 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 40 CONTINUE + END IF + END IF +* + C1 = SUBNAM( 1: 1 ) + SNAME = C1.EQ.'S' .OR. C1.EQ.'D' + CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' + IF( .NOT.( CNAME .OR. SNAME ) ) + $ RETURN + C2 = SUBNAM( 2: 3 ) + C3 = SUBNAM( 4: 6 ) + C4 = C3( 2: 3 ) +* + GO TO ( 50, 60, 70 )ISPEC +* + 50 CONTINUE +* +* ISPEC = 1: block size +* +* In these examples, separate code is provided for setting NB for +* real and complex. We assume that NB will take the same value in +* single or double precision. +* + NB = 1 +* + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'PO' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRF' ) THEN + NB = 64 + ELSE IF( C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( C2.EQ.'GB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'PB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'TR' ) THEN + IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'LA' ) THEN + IF( C3.EQ.'UUM' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN + IF( C3.EQ.'EBZ' ) THEN + NB = 1 + END IF + END IF + ILAENV = NB + RETURN +* + 60 CONTINUE +* +* ISPEC = 2: minimum block size +* + NBMIN = 2 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NBMIN = 8 + ELSE + NBMIN = 8 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + END IF + ILAENV = NBMIN + RETURN +* + 70 CONTINUE +* +* ISPEC = 3: crossover point +* + NX = 0 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + END IF + ILAENV = NX + RETURN +* + 80 CONTINUE +* +* ISPEC = 4: number of shifts (used by xHSEQR) +* + ILAENV = 6 + RETURN +* + 90 CONTINUE +* +* ISPEC = 5: minimum column dimension (not used) +* + ILAENV = 2 + RETURN +* + 100 CONTINUE +* +* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) +* + ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) + RETURN +* + 110 CONTINUE +* +* ISPEC = 7: number of processors (not used) +* + ILAENV = 1 + RETURN +* + 120 CONTINUE +* +* ISPEC = 8: crossover point for multishift (used by xHSEQR) +* + ILAENV = 50 + RETURN +* + 130 CONTINUE +* +* ISPEC = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* + ILAENV = 25 + RETURN +* + 140 CONTINUE +* +* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 1, 0.0, 1.0 ) + END IF + RETURN +* + 150 CONTINUE +* +* ISPEC = 11: infinity arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 0, 0.0, 1.0 ) + END IF + RETURN +* + 160 CONTINUE +* +* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. +* + ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + RETURN +* +* End of ILAENV +* + END + INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, ISPEC, LWORK, N + CHARACTER NAME*( * ), OPTS*( * ) +* +* Purpose +* ======= +* +* This program sets problem and machine dependent parameters +* useful for xHSEQR and its subroutines. It is called whenever +* ILAENV is called with 12 <= ISPEC <= 16 +* +* Arguments +* ========= +* +* ISPEC (input) integer scalar +* ISPEC specifies which tunable parameter IPARMQ should +* return. +* +* ISPEC=12: (INMIN) Matrices of order nmin or less +* are sent directly to xLAHQR, the implicit +* double shift QR algorithm. NMIN must be +* at least 11. +* +* ISPEC=13: (INWIN) Size of the deflation window. +* This is best set greater than or equal to +* the number of simultaneous shifts NS. +* Larger matrices benefit from larger deflation +* windows. +* +* ISPEC=14: (INIBL) Determines when to stop nibbling and +* invest in an (expensive) multi-shift QR sweep. +* If the aggressive early deflation subroutine +* finds LD converged eigenvalues from an order +* NW deflation window and LD.GT.(NW*NIBBLE)/100, +* then the next QR sweep is skipped and early +* deflation is applied immediately to the +* remaining active diagonal block. Setting +* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a +* multi-shift QR sweep whenever early deflation +* finds a converged eigenvalue. Setting +* IPARMQ(ISPEC=14) greater than or equal to 100 +* prevents TTQRE from skipping a multi-shift +* QR sweep. +* +* ISPEC=15: (NSHFTS) The number of simultaneous shifts in +* a multi-shift QR iteration. +* +* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the +* following meanings. +* 0: During the multi-shift QR sweep, +* xLAQR5 does not accumulate reflections and +* does not use matrix-matrix multiply to +* update the far-from-diagonal matrix +* entries. +* 1: During the multi-shift QR sweep, +* xLAQR5 and/or xLAQRaccumulates reflections +* and uses +* matrix-matrix multiply to update the +* far-from-diagonal matrix entries. +* 2: During the multi-shift QR sweep. +* xLAQR5 accumulates reflections and takes +* advantage of 2-by-2 block structure during +* matrix-matrix multiplies. +* (If xTRMM is slower than xGEMM, then +* IPARMQ(ISPEC=16)=1 may be more efficient than +* IPARMQ(ISPEC=16)=2 despite the greater level of +* arithmetic work implied by the latter choice.) +* +* NAME (input) character string +* Name of the calling subroutine +* +* OPTS (input) character string +* This is a concatenation of the string arguments to +* TTQRE. +* +* N (input) integer scalar +* N is the order of the Hessenberg matrix H. +* +* ILO (input) INTEGER +* IHI (input) INTEGER +* It is assumed that H is already upper triangular +* in rows and columns 1:ILO-1 and IHI+1:N. +* +* LWORK (input) integer scalar +* The amount of workspace available. +* +* Further Details +* =============== +* +* Little is known about how best to choose these parameters. +* It is possible to use different values of the parameters +* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. +* +* It is probably best to choose different parameters for +* different matrices and different parameters at different +* times during the iteration, but this has not been +* implemented --- yet. +* +* +* The best choices of most of the parameters depend +* in an ill-understood way on the relative execution +* rate of xLAQR3 and xLAQR5 and on the nature of each +* particular eigenvalue problem. Experiment may be the +* only practical way to determine which choices are most +* effective. +* +* Following is a list of default values supplied by IPARMQ. +* These defaults may be adjusted in order to attain better +* performance in any particular computational environment. +* +* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. +* Default: 75. (Must be at least 11.) +* +* IPARMQ(ISPEC=13) Recommended deflation window size. +* This depends on ILO, IHI and NS, the +* number of simultaneous shifts returned +* by IPARMQ(ISPEC=15). The default for +* (IHI-ILO+1).LE.500 is NS. The default +* for (IHI-ILO+1).GT.500 is 3*NS/2. +* +* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. +* +* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. +* a multi-shift QR iteration. +* +* If IHI-ILO+1 is ... +* +* greater than ...but less ... the +* or equal to ... than default is +* +* 0 30 NS = 2+ +* 30 60 NS = 4+ +* 60 150 NS = 10 +* 150 590 NS = ** +* 590 3000 NS = 64 +* 3000 6000 NS = 128 +* 6000 infinity NS = 256 +* +* (+) By default matrices of this order are +* passed to the implicit double shift routine +* xLAHQR. See IPARMQ(ISPEC=12) above. These +* values of NS are used only in case of a rare +* xLAHQR failure. +* +* (**) The asterisks (**) indicate an ad-hoc +* function increasing from 10 to 64. +* +* IPARMQ(ISPEC=16) Select structured matrix multiply. +* (See ISPEC=16 above for details.) +* Default: 3. +* +* ================================================================ +* .. Parameters .. + INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 + PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, + $ ISHFTS = 15, IACC22 = 16 ) + INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP + PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, + $ NIBBLE = 14, KNWSWP = 500 ) + REAL TWO + PARAMETER ( TWO = 2.0 ) +* .. +* .. Local Scalars .. + INTEGER NH, NS +* .. +* .. Intrinsic Functions .. + INTRINSIC LOG, MAX, MOD, NINT, REAL +* .. +* .. Executable Statements .. + IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. + $ ( ISPEC.EQ.IACC22 ) ) THEN +* +* ==== Set the number simultaneous shifts ==== +* + NH = IHI - ILO + 1 + NS = 2 + IF( NH.GE.30 ) + $ NS = 4 + IF( NH.GE.60 ) + $ NS = 10 + IF( NH.GE.150 ) + $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) + IF( NH.GE.590 ) + $ NS = 64 + IF( NH.GE.3000 ) + $ NS = 128 + IF( NH.GE.6000 ) + $ NS = 256 + NS = MAX( 2, NS-MOD( NS, 2 ) ) + END IF +* + IF( ISPEC.EQ.INMIN ) THEN +* +* +* ===== Matrices of order smaller than NMIN get sent +* . to xLAHQR, the classic double shift algorithm. +* . This must be at least 11. ==== +* + IPARMQ = NMIN +* + ELSE IF( ISPEC.EQ.INIBL ) THEN +* +* ==== INIBL: skip a multi-shift qr iteration and +* . whenever aggressive early deflation finds +* . at least (NIBBLE*(window size)/100) deflations. ==== +* + IPARMQ = NIBBLE +* + ELSE IF( ISPEC.EQ.ISHFTS ) THEN +* +* ==== NSHFTS: The number of simultaneous shifts ===== +* + IPARMQ = NS +* + ELSE IF( ISPEC.EQ.INWIN ) THEN +* +* ==== NW: deflation window size. ==== +* + IF( NH.LE.KNWSWP ) THEN + IPARMQ = NS + ELSE + IPARMQ = 3*NS / 2 + END IF +* + ELSE IF( ISPEC.EQ.IACC22 ) THEN +* +* ==== IACC22: Whether to accumulate reflections +* . before updating the far-from-diagonal elements +* . and whether to use 2-by-2 block structure while +* . doing it. A small amount of work could be saved +* . by making this choice dependent also upon the +* . NH=IHI-ILO+1. +* + IPARMQ = 0 + IF( NS.GE.KACMIN ) + $ IPARMQ = 1 + IF( NS.GE.K22MIN ) + $ IPARMQ = 2 +* + ELSE +* ===== invalid value of ispec ===== + IPARMQ = -1 +* + END IF +* +* ==== End of IPARMQ ==== +* + END + diff --git a/python/delsparse_src/real_precision.f90 b/python/delsparse_src/real_precision.f90 new file mode 100644 index 0000000..511e265 --- /dev/null +++ b/python/delsparse_src/real_precision.f90 @@ -0,0 +1,4 @@ +MODULE REAL_PRECISION ! HOMPACK90 module for 64-bit arithmetic. +INTEGER, PARAMETER:: R8=SELECTED_REAL_KIND(13) +END MODULE REAL_PRECISION + diff --git a/python/delsparse_src/slatec.f b/python/delsparse_src/slatec.f new file mode 100755 index 0000000..c652a26 --- /dev/null +++ b/python/delsparse_src/slatec.f @@ -0,0 +1,5023 @@ +*DECK DLSEI + SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, + + RNORML, MODE, WS, IP) +C***BEGIN PROLOGUE DLSEI +C***PURPOSE Solve a linearly constrained least squares problem with +C equality and inequality constraints, and optionally compute +C a covariance matrix. +C***LIBRARY SLATEC +C***CATEGORY K1A2A, D9 +C***TYPE DOUBLE PRECISION (LSEI-S, DLSEI-D) +C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, +C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, +C QUADRATIC PROGRAMMING +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C Abstract +C +C This subprogram solves a linearly constrained least squares +C problem with both equality and inequality constraints, and, if the +C user requests, obtains a covariance matrix of the solution +C parameters. +C +C Suppose there are given matrices E, A and G of respective +C dimensions ME by N, MA by N and MG by N, and vectors F, B and H of +C respective lengths ME, MA and MG. This subroutine solves the +C linearly constrained least squares problem +C +C EX = F, (E ME by N) (equations to be exactly +C satisfied) +C AX = B, (A MA by N) (equations to be +C approximately satisfied, +C least squares sense) +C GX .GE. H,(G MG by N) (inequality constraints) +C +C The inequalities GX .GE. H mean that every component of the +C product GX must be .GE. the corresponding component of H. +C +C In case the equality constraints cannot be satisfied, a +C generalized inverse solution residual vector length is obtained +C for F-EX. This is the minimal length possible for F-EX. +C +C Any values ME .GE. 0, MA .GE. 0, or MG .GE. 0 are permitted. The +C rank of the matrix E is estimated during the computation. We call +C this value KRANKE. It is an output parameter in IP(1) defined +C below. Using a generalized inverse solution of EX=F, a reduced +C least squares problem with inequality constraints is obtained. +C The tolerances used in these tests for determining the rank +C of E and the rank of the reduced least squares problem are +C given in Sandia Tech. Rept. SAND-78-1290. They can be +C modified by the user if new values are provided in +C the option list of the array PRGOPT(*). +C +C The user must dimension all arrays appearing in the call list.. +C W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2) +C where K=MAX(MA+MG,N). This allows for a solution of a range of +C problems in the given working space. The dimension of WS(*) +C given is a necessary overestimate. Once a particular problem +C has been run, the output parameter IP(3) gives the actual +C dimension required for that problem. +C +C The parameters for DLSEI( ) are +C +C Input.. All TYPE REAL variables are DOUBLE PRECISION +C +C W(*,*),MDW, The array W(*,*) is doubly subscripted with +C ME,MA,MG,N first dimensioning parameter equal to MDW. +C For this discussion let us call M = ME+MA+MG. Then +C MDW must satisfy MDW .GE. M. The condition +C MDW .LT. M is an error. +C +C The array W(*,*) contains the matrices and vectors +C +C (E F) +C (A B) +C (G H) +C +C in rows and columns 1,...,M and 1,...,N+1 +C respectively. +C +C The integers ME, MA, and MG are the +C respective matrix row dimensions +C of E, A and G. Each matrix has N columns. +C +C PRGOPT(*) This real-valued array is the option vector. +C If the user is satisfied with the nominal +C subprogram features set +C +C PRGOPT(1)=1 (or PRGOPT(1)=1.0) +C +C Otherwise PRGOPT(*) is a linked list consisting of +C groups of data of the following form +C +C LINK +C KEY +C DATA SET +C +C The parameters LINK and KEY are each one word. +C The DATA SET can be comprised of several words. +C The number of items depends on the value of KEY. +C The value of LINK points to the first +C entry of the next group of data within +C PRGOPT(*). The exception is when there are +C no more options to change. In that +C case, LINK=1 and the values KEY and DATA SET +C are not referenced. The general layout of +C PRGOPT(*) is as follows. +C +C ...PRGOPT(1) = LINK1 (link to first entry of next group) +C . PRGOPT(2) = KEY1 (key to the option change) +C . PRGOPT(3) = data value (data value for this change) +C . . +C . . +C . . +C ...PRGOPT(LINK1) = LINK2 (link to the first entry of +C . next group) +C . PRGOPT(LINK1+1) = KEY2 (key to the option change) +C . PRGOPT(LINK1+2) = data value +C ... . +C . . +C . . +C ...PRGOPT(LINK) = 1 (no more options to change) +C +C Values of LINK that are nonpositive are errors. +C A value of LINK .GT. NLINK=100000 is also an error. +C This helps prevent using invalid but positive +C values of LINK that will probably extend +C beyond the program limits of PRGOPT(*). +C Unrecognized values of KEY are ignored. The +C order of the options is arbitrary and any number +C of options can be changed with the following +C restriction. To prevent cycling in the +C processing of the option array, a count of the +C number of options changed is maintained. +C Whenever this count exceeds NOPT=1000, an error +C message is printed and the subprogram returns. +C +C Options.. +C +C KEY=1 +C Compute in W(*,*) the N by N +C covariance matrix of the solution variables +C as an output parameter. Nominally the +C covariance matrix will not be computed. +C (This requires no user input.) +C The data set for this option is a single value. +C It must be nonzero when the covariance matrix +C is desired. If it is zero, the covariance +C matrix is not computed. When the covariance matrix +C is computed, the first dimensioning parameter +C of the array W(*,*) must satisfy MDW .GE. MAX(M,N). +C +C KEY=10 +C Suppress scaling of the inverse of the +C normal matrix by the scale factor RNORM**2/ +C MAX(1, no. of degrees of freedom). This option +C only applies when the option for computing the +C covariance matrix (KEY=1) is used. With KEY=1 and +C KEY=10 used as options the unscaled inverse of the +C normal matrix is returned in W(*,*). +C The data set for this option is a single value. +C When it is nonzero no scaling is done. When it is +C zero scaling is done. The nominal case is to do +C scaling so if option (KEY=1) is used alone, the +C matrix will be scaled on output. +C +C KEY=2 +C Scale the nonzero columns of the +C entire data matrix. +C (E) +C (A) +C (G) +C +C to have length one. The data set for this +C option is a single value. It must be +C nonzero if unit length column scaling +C is desired. +C +C KEY=3 +C Scale columns of the entire data matrix +C (E) +C (A) +C (G) +C +C with a user-provided diagonal matrix. +C The data set for this option consists +C of the N diagonal scaling factors, one for +C each matrix column. +C +C KEY=4 +C Change the rank determination tolerance for +C the equality constraint equations from +C the nominal value of SQRT(DRELPR). This quantity can +C be no smaller than DRELPR, the arithmetic- +C storage precision. The quantity DRELPR is the +C largest positive number such that T=1.+DRELPR +C satisfies T .EQ. 1. The quantity used +C here is internally restricted to be at +C least DRELPR. The data set for this option +C is the new tolerance. +C +C KEY=5 +C Change the rank determination tolerance for +C the reduced least squares equations from +C the nominal value of SQRT(DRELPR). This quantity can +C be no smaller than DRELPR, the arithmetic- +C storage precision. The quantity used +C here is internally restricted to be at +C least DRELPR. The data set for this option +C is the new tolerance. +C +C For example, suppose we want to change +C the tolerance for the reduced least squares +C problem, compute the covariance matrix of +C the solution parameters, and provide +C column scaling for the data matrix. For +C these options the dimension of PRGOPT(*) +C must be at least N+9. The Fortran statements +C defining these options would be as follows: +C +C PRGOPT(1)=4 (link to entry 4 in PRGOPT(*)) +C PRGOPT(2)=1 (covariance matrix key) +C PRGOPT(3)=1 (covariance matrix wanted) +C +C PRGOPT(4)=7 (link to entry 7 in PRGOPT(*)) +C PRGOPT(5)=5 (least squares equas. tolerance key) +C PRGOPT(6)=... (new value of the tolerance) +C +C PRGOPT(7)=N+9 (link to entry N+9 in PRGOPT(*)) +C PRGOPT(8)=3 (user-provided column scaling key) +C +C CALL DCOPY (N, D, 1, PRGOPT(9), 1) (Copy the N +C scaling factors from the user array D(*) +C to PRGOPT(9)-PRGOPT(N+8)) +C +C PRGOPT(N+9)=1 (no more options to change) +C +C The contents of PRGOPT(*) are not modified +C by the subprogram. +C The options for WNNLS( ) can also be included +C in this array. The values of KEY recognized +C by WNNLS( ) are 6, 7 and 8. Their functions +C are documented in the usage instructions for +C subroutine WNNLS( ). Normally these options +C do not need to be modified when using DLSEI( ). +C +C IP(1), The amounts of working storage actually +C IP(2) allocated for the working arrays WS(*) and +C IP(*), respectively. These quantities are +C compared with the actual amounts of storage +C needed by DLSEI( ). Insufficient storage +C allocated for either WS(*) or IP(*) is an +C error. This feature was included in DLSEI( ) +C because miscalculating the storage formulas +C for WS(*) and IP(*) might very well lead to +C subtle and hard-to-find execution errors. +C +C The length of WS(*) must be at least +C +C LW = 2*(ME+N)+K+(MG+2)*(N+7) +C +C where K = max(MA+MG,N) +C This test will not be made if IP(1).LE.0. +C +C The length of IP(*) must be at least +C +C LIP = MG+2*N+2 +C This test will not be made if IP(2).LE.0. +C +C Output.. All TYPE REAL variables are DOUBLE PRECISION +C +C X(*),RNORME, The array X(*) contains the solution parameters +C RNORML if the integer output flag MODE = 0 or 1. +C The definition of MODE is given directly below. +C When MODE = 0 or 1, RNORME and RNORML +C respectively contain the residual vector +C Euclidean lengths of F - EX and B - AX. When +C MODE=1 the equality constraint equations EX=F +C are contradictory, so RNORME .NE. 0. The residual +C vector F-EX has minimal Euclidean length. For +C MODE .GE. 2, none of these parameters is defined. +C +C MODE Integer flag that indicates the subprogram +C status after completion. If MODE .GE. 2, no +C solution has been computed. +C +C MODE = +C +C 0 Both equality and inequality constraints +C are compatible and have been satisfied. +C +C 1 Equality constraints are contradictory. +C A generalized inverse solution of EX=F was used +C to minimize the residual vector length F-EX. +C In this sense, the solution is still meaningful. +C +C 2 Inequality constraints are contradictory. +C +C 3 Both equality and inequality constraints +C are contradictory. +C +C The following interpretation of +C MODE=1,2 or 3 must be made. The +C sets consisting of all solutions +C of the equality constraints EX=F +C and all vectors satisfying GX .GE. H +C have no points in common. (In +C particular this does not say that +C each individual set has no points +C at all, although this could be the +C case.) +C +C 4 Usage error occurred. The value +C of MDW is .LT. ME+MA+MG, MDW is +C .LT. N and a covariance matrix is +C requested, or the option vector +C PRGOPT(*) is not properly defined, +C or the lengths of the working arrays +C WS(*) and IP(*), when specified in +C IP(1) and IP(2) respectively, are not +C long enough. +C +C W(*,*) The array W(*,*) contains the N by N symmetric +C covariance matrix of the solution parameters, +C provided this was requested on input with +C the option vector PRGOPT(*) and the output +C flag is returned with MODE = 0 or 1. +C +C IP(*) The integer working array has three entries +C that provide rank and working array length +C information after completion. +C +C IP(1) = rank of equality constraint +C matrix. Define this quantity +C as KRANKE. +C +C IP(2) = rank of reduced least squares +C problem. +C +C IP(3) = the amount of storage in the +C working array WS(*) that was +C actually used by the subprogram. +C The formula given above for the length +C of WS(*) is a necessary overestimate. +C If exactly the same problem matrices +C are used in subsequent executions, +C the declared dimension of WS(*) can +C be reduced to this output value. +C User Designated +C Working Arrays.. +C +C WS(*),IP(*) These are respectively type real +C and type integer working arrays. +C Their required minimal lengths are +C given above. +C +C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for +C linear least squares problems with equality and +C nonnegativity constraints, Report SAND77-0552, Sandia +C Laboratories, June 1978. +C K. H. Haskell and R. J. Hanson, Selected algorithms for +C the linearly constrained least squares problem - a +C users guide, Report SAND78-1290, Sandia Laboratories, +C August 1979. +C K. H. Haskell and R. J. Hanson, An algorithm for +C linear least squares problems with equality and +C nonnegativity constraints, Mathematical Programming +C 21 (1981), pp. 98-118. +C R. J. Hanson and K. H. Haskell, Two algorithms for the +C linearly constrained least squares problem, ACM +C Transactions on Mathematical Software, September 1982. +C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, +C DNRM2, DSCAL, DSWAP, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and extensively revised (WRB & RWC) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900510 Convert XERRWV calls to XERMSG calls. (RWC) +C 900604 DP version created from SP version. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C 180613 Removed prints and replaced DP --> DOUBLE PRECISION. (THC) +C***END PROLOGUE DLSEI + + INTEGER IP(3), MA, MDW, ME, MG, MODE, N + DOUBLE PRECISION PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*) +C + EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, DNRM2, + * DSCAL, DSWAP + DOUBLE PRECISION D1MACH, DASUM, DDOT, DNRM2 +C + DOUBLE PRECISION DRELPR, ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, + * SN, SNMAX, T, TAU, UJ, UP, VJ, XNORM, XNRME + INTEGER I, IMAX, J, JP1, K, KEY, KRANKE, LAST, LCHK, LINK, M, + * MAPKE1, MDEQC, MEND, MEP1, N1, N2, NEXT, NLINK, NOPT, NP1, + * NTIMES + LOGICAL COV, FIRST +C CHARACTER*8 XERN1, XERN2, XERN3, XERN4 + SAVE FIRST, DRELPR +C + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DLSEI +C +C Set the nominal tolerance used in the code for the equality +C constraint equations. +C + IF (FIRST) DRELPR = D1MACH(4) + FIRST = .FALSE. + TAU = SQRT(DRELPR) +C +C Check that enough storage was allocated in WS(*) and IP(*). +C + MODE = 4 + IF (MIN(N,ME,MA,MG) .LT. 0) THEN +C WRITE (XERN1, '(I8)') N +C WRITE (XERN2, '(I8)') ME +C WRITE (XERN3, '(I8)') MA +C WRITE (XERN4, '(I8)') MG +C CALL XERMSG ('SLATEC', 'LSEI', 'ALL OF THE VARIABLES N, ME,' // +C * ' MA, MG MUST BE .GE. 0$$ENTERED ROUTINE WITH' // +C * '$$N = ' // XERN1 // +C * '$$ME = ' // XERN2 // +C * '$$MA = ' // XERN3 // +C * '$$MG = ' // XERN4, 2, 1) + RETURN + ENDIF +C + IF (IP(1).GT.0) THEN + LCHK = 2*(ME+N) + MAX(MA+MG,N) + (MG+2)*(N+7) + IF (IP(1).LT.LCHK) THEN +C WRITE (XERN1, '(I8)') LCHK +C CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // +C * 'ALLOCATED FOR WS(*), NEED LW = ' // XERN1, 2, 1) + RETURN + ENDIF + ENDIF +C + IF (IP(2).GT.0) THEN + LCHK = MG + 2*N + 2 + IF (IP(2).LT.LCHK) THEN +C WRITE (XERN1, '(I8)') LCHK +C CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // +C * 'ALLOCATED FOR IP(*), NEED LIP = ' // XERN1, 2, 1) + RETURN + ENDIF + ENDIF +C +C Compute number of possible right multiplying Householder +C transformations. +C + M = ME + MA + MG + IF (N.LE.0 .OR. M.LE.0) THEN + MODE = 0 + RNORME = 0 + RNORML = 0 + RETURN + ENDIF +C + IF (MDW.LT.M) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', 'MDW.LT.ME+MA+MG IS AN ERROR', +C + 2, 1) + RETURN + ENDIF +C + NP1 = N + 1 + KRANKE = MIN(ME,N) + N1 = 2*KRANKE + 1 + N2 = N1 + N +C +C Set nominal values. +C +C The nominal column scaling used in the code is +C the identity scaling. +C + CALL DCOPY (N, 1.D0, 0, WS(N1), 1) +C +C No covariance matrix is nominally computed. +C + COV = .FALSE. +C +C Process option vector. +C Define bound for number of options to change. +C + NOPT = 1000 + NTIMES = 0 +C +C Define bound for positive values of LINK. +C + NLINK = 100000 + LAST = 1 + LINK = PRGOPT(1) + IF (LINK.EQ.0 .OR. LINK.GT.NLINK) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', +C + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) + RETURN + ENDIF +C + 100 IF (LINK.GT.1) THEN + NTIMES = NTIMES + 1 + IF (NTIMES.GT.NOPT) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', +C + 'THE LINKS IN THE OPTION VECTOR ARE CYCLING.', 2, 1) + RETURN + ENDIF +C + KEY = PRGOPT(LAST+1) + IF (KEY.EQ.1) THEN + COV = PRGOPT(LAST+2) .NE. 0.D0 + ELSEIF (KEY.EQ.2 .AND. PRGOPT(LAST+2).NE.0.D0) THEN + DO 110 J = 1,N + T = DNRM2(M,W(1,J),1) + IF (T.NE.0.D0) T = 1.D0/T + WS(J+N1-1) = T + 110 CONTINUE + ELSEIF (KEY.EQ.3) THEN + CALL DCOPY (N, PRGOPT(LAST+2), 1, WS(N1), 1) + ELSEIF (KEY.EQ.4) THEN + TAU = MAX(DRELPR,PRGOPT(LAST+2)) + ENDIF +C + NEXT = PRGOPT(LINK) + IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', +C + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) + RETURN + ENDIF +C + LAST = LINK + LINK = NEXT + GO TO 100 + ENDIF +C + DO 120 J = 1,N + CALL DSCAL (M, WS(N1+J-1), W(1,J), 1) + 120 CONTINUE +C + IF (COV .AND. MDW.LT.N) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', +C + 'MDW .LT. N WHEN COV MATRIX NEEDED, IS AN ERROR', 2, 1) + RETURN + ENDIF +C +C Problem definition and option vector OK. +C + MODE = 0 +C +C Compute norm of equality constraint matrix and right side. +C + ENORM = 0.D0 + DO 130 J = 1,N + ENORM = MAX(ENORM,DASUM(ME,W(1,J),1)) + 130 CONTINUE +C + FNORM = DASUM(ME,W(1,NP1),1) + SNMAX = 0.D0 + RNMAX = 0.D0 + DO 150 I = 1,KRANKE +C +C Compute maximum ratio of vector lengths. Partition is at +C column I. +C + DO 140 K = I,ME + SN = DDOT(N-I+1,W(K,I),MDW,W(K,I),MDW) + RN = DDOT(I-1,W(K,1),MDW,W(K,1),MDW) + IF (RN.EQ.0.D0 .AND. SN.GT.SNMAX) THEN + SNMAX = SN + IMAX = K + ELSEIF (K.EQ.I .OR. SN*RNMAX.GT.RN*SNMAX) THEN + SNMAX = SN + RNMAX = RN + IMAX = K + ENDIF + 140 CONTINUE +C +C Interchange rows if necessary. +C + IF (I.NE.IMAX) CALL DSWAP (NP1, W(I,1), MDW, W(IMAX,1), MDW) + IF (SNMAX.GT.RNMAX*TAU**2) THEN +C +C Eliminate elements I+1,...,N in row I. +C + CALL DH12 (1, I, I+1, N, W(I,1), MDW, WS(I), W(I+1,1), MDW, + + 1, M-I) + ELSE + KRANKE = I - 1 + GO TO 160 + ENDIF + 150 CONTINUE +C +C Save diagonal terms of lower trapezoidal matrix. +C + 160 CALL DCOPY (KRANKE, W, MDW+1, WS(KRANKE+1), 1) +C +C Use Householder transformation from left to achieve +C KRANKE by KRANKE upper triangular form. +C + IF (KRANKE.LT.ME) THEN + DO 170 K = KRANKE,1,-1 +C +C Apply transformation to matrix cols. 1,...,K-1. +C + CALL DH12 (1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, + * K-1) +C +C Apply to rt side vector. +C + CALL DH12 (2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, + + 1, 1) + 170 CONTINUE + ENDIF +C +C Solve for variables 1,...,KRANKE in new coordinates. +C + CALL DCOPY (KRANKE, W(1, NP1), 1, X, 1) + DO 180 I = 1,KRANKE + X(I) = (X(I)-DDOT(I-1,W(I,1),MDW,X,1))/W(I,I) + 180 CONTINUE +C +C Compute residuals for reduced problem. +C + MEP1 = ME + 1 + RNORML = 0.D0 + DO 190 I = MEP1,M + W(I,NP1) = W(I,NP1) - DDOT(KRANKE,W(I,1),MDW,X,1) + SN = DDOT(KRANKE,W(I,1),MDW,W(I,1),MDW) + RN = DDOT(N-KRANKE,W(I,KRANKE+1),MDW,W(I,KRANKE+1),MDW) + IF (RN.LE.SN*TAU**2 .AND. KRANKE.LT.N) + * CALL DCOPY (N-KRANKE, 0.D0, 0, W(I,KRANKE+1), MDW) + 190 CONTINUE +C +C Compute equality constraint equations residual length. +C + RNORME = DNRM2(ME-KRANKE,W(KRANKE+1,NP1),1) +C +C Move reduced problem data upward if KRANKE.LT.ME. +C + IF (KRANKE.LT.ME) THEN + DO 200 J = 1,NP1 + CALL DCOPY (M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1) + 200 CONTINUE + ENDIF +C +C Compute solution of reduced problem. +C + CALL DLSI(W(KRANKE+1, KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT, + + X(KRANKE+1), RNORML, MODE, WS(N2), IP(2)) +C +C Test for consistency of equality constraints. +C + IF (ME.GT.0) THEN + MDEQC = 0 + XNRME = DASUM(KRANKE,W(1,NP1),1) + IF (RNORME.GT.TAU*(ENORM*XNRME+FNORM)) MDEQC = 1 + MODE = MODE + MDEQC +C +C Check if solution to equality constraints satisfies inequality +C constraints when there are no degrees of freedom left. +C + IF (KRANKE.EQ.N .AND. MG.GT.0) THEN + XNORM = DASUM(N,X,1) + MAPKE1 = MA + KRANKE + 1 + MEND = MA + KRANKE + MG + DO 210 I = MAPKE1,MEND + SIZE = DASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1)) + IF (W(I,NP1).GT.TAU*SIZE) THEN + MODE = MODE + 2 + GO TO 290 + ENDIF + 210 CONTINUE + ENDIF + ENDIF +C +C Replace diagonal terms of lower trapezoidal matrix. +C + IF (KRANKE.GT.0) THEN + CALL DCOPY (KRANKE, WS(KRANKE+1), 1, W, MDW+1) +C +C Reapply transformation to put solution in original coordinates. +C + DO 220 I = KRANKE,1,-1 + CALL DH12 (2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1) + 220 CONTINUE +C +C Compute covariance matrix of equality constrained problem. +C + IF (COV) THEN + DO 270 J = MIN(KRANKE,N-1),1,-1 + RB = WS(J)*W(J,J) + IF (RB.NE.0.D0) RB = 1.D0/RB + JP1 = J + 1 + DO 230 I = JP1,N + W(I,J) = RB*DDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW) + 230 CONTINUE +C + GAM = 0.5D0*RB*DDOT(N-J,W(JP1,J),1,W(J,JP1),MDW) + CALL DAXPY (N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1) + DO 250 I = JP1,N + DO 240 K = I,N + W(I,K) = W(I,K) + W(J,I)*W(K,J) + W(I,J)*W(J,K) + W(K,I) = W(I,K) + 240 CONTINUE + 250 CONTINUE + UJ = WS(J) + VJ = GAM*UJ + W(J,J) = UJ*VJ + UJ*VJ + DO 260 I = JP1,N + W(J,I) = UJ*W(I,J) + VJ*W(J,I) + 260 CONTINUE + CALL DCOPY (N-J, W(J, JP1), MDW, W(JP1,J), 1) + 270 CONTINUE + ENDIF + ENDIF +C +C Apply the scaling to the covariance matrix. +C + IF (COV) THEN + DO 280 I = 1,N + CALL DSCAL (N, WS(I+N1-1), W(I,1), MDW) + CALL DSCAL (N, WS(I+N1-1), W(1,I), 1) + 280 CONTINUE + ENDIF +C +C Rescale solution vector. +C + 290 IF (MODE.LE.1) THEN + DO 300 J = 1,N + X(J) = X(J)*WS(N1+J-1) + 300 CONTINUE + ENDIF +C + IP(1) = KRANKE + IP(3) = IP(3) + 2*KRANKE + N + RETURN + END +*DECK DLSI + SUBROUTINE DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, + + IP) +C***BEGIN PROLOGUE DLSI +C***SUBSIDIARY +C***PURPOSE Subsidiary to DLSEI +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (LSI-S, DLSI-D) +C***AUTHOR Hanson, R. J., (SNLA) +C***DESCRIPTION +C +C This is a companion subprogram to DLSEI. The documentation for +C DLSEI has complete usage instructions. +C +C Solve.. +C AX = B, A MA by N (least squares equations) +C subject to.. +C +C GX.GE.H, G MG by N (inequality constraints) +C +C Input.. +C +C W(*,*) contains (A B) in rows 1,...,MA+MG, cols 1,...,N+1. +C (G H) +C +C MDW,MA,MG,N +C contain (resp) var. dimension of W(*,*), +C and matrix dimensions. +C +C PRGOPT(*), +C Program option vector. +C +C OUTPUT.. +C +C X(*),RNORM +C +C Solution vector(unless MODE=2), length of AX-B. +C +C MODE +C =0 Inequality constraints are compatible. +C =2 Inequality constraints contradictory. +C +C WS(*), +C Working storage of dimension K+N+(MG+2)*(N+7), +C where K=MAX(MA+MG,N). +C IP(MG+2*N+1) +C Integer working storage +C +C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, +C DLPDP, DSCAL, DSWAP +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and extensively revised (WRB & RWC) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900604 DP version created from SP version. (RWC) +C 920422 Changed CALL to DHFTI to include variable MA. (WRB) +C***END PROLOGUE DLSI + + INTEGER IP(*), MA, MDW, MG, MODE, N + DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*) +C + EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, DLPDP, + * DSCAL, DSWAP + DOUBLE PRECISION D1MACH, DASUM, DDOT +C + DOUBLE PRECISION ANORM, DRELPR, FAC, GAM, RB, TAU, TOL, XNORM, + * TMP_NORM(1) + INTEGER I, J, K, KEY, KRANK, KRM1, KRP1, L, LAST, LINK, M, MAP1, + * MDLPDP, MINMAN, N1, N2, N3, NEXT, NP1 + LOGICAL COV, FIRST, SCLCOV +C + SAVE DRELPR, FIRST + DATA FIRST /.TRUE./ +C +C***FIRST EXECUTABLE STATEMENT DLSI +C +C Set the nominal tolerance used in the code. +C + IF (FIRST) DRELPR = D1MACH(4) + FIRST = .FALSE. + TOL = SQRT(DRELPR) +C + MODE = 0 + RNORM = 0.D0 + M = MA + MG + NP1 = N + 1 + KRANK = 0 + IF (N.LE.0 .OR. M.LE.0) GO TO 370 +C +C To process option vector. +C + COV = .FALSE. + SCLCOV = .TRUE. + LAST = 1 + LINK = PRGOPT(1) +C + 100 IF (LINK.GT.1) THEN + KEY = PRGOPT(LAST+1) + IF (KEY.EQ.1) COV = PRGOPT(LAST+2) .NE. 0.D0 + IF (KEY.EQ.10) SCLCOV = PRGOPT(LAST+2) .EQ. 0.D0 + IF (KEY.EQ.5) TOL = MAX(DRELPR,PRGOPT(LAST+2)) + NEXT = PRGOPT(LINK) + LAST = LINK + LINK = NEXT + GO TO 100 + ENDIF +C +C Compute matrix norm of least squares equations. +C + ANORM = 0.D0 + DO 110 J = 1,N + ANORM = MAX(ANORM,DASUM(MA,W(1,J),1)) + 110 CONTINUE +C +C Set tolerance for DHFTI( ) rank test. +C + TAU = TOL*ANORM +C +C Compute Householder orthogonal decomposition of matrix. +C + CALL DCOPY (N, 0.D0, 0, WS, 1) + CALL DCOPY (MA, W(1, NP1), 1, WS, 1) + K = MAX(M,N) + MINMAN = MIN(MA,N) + N1 = K + 1 + N2 = N1 + N + CALL DHFTI (W, MDW, MA, N, WS, MA, 1, TAU, KRANK, TMP_NORM, + + WS(N2), WS(N1), IP) + RNORM = TMP_NORM(1) + FAC = 1.D0 + GAM = MA - KRANK + IF (KRANK.LT.MA .AND. SCLCOV) FAC = RNORM**2/GAM +C +C Reduce to DLPDP and solve. +C + MAP1 = MA + 1 +C +C Compute inequality rt-hand side for DLPDP. +C + IF (MA.LT.M) THEN + IF (MINMAN.GT.0) THEN + DO 120 I = MAP1,M + W(I,NP1) = W(I,NP1) - DDOT(N,W(I,1),MDW,WS,1) + 120 CONTINUE +C +C Apply permutations to col. of inequality constraint matrix. +C + DO 130 I = 1,MINMAN + CALL DSWAP (MG, W(MAP1,I), 1, W(MAP1,IP(I)), 1) + 130 CONTINUE +C +C Apply Householder transformations to constraint matrix. +C + IF (KRANK.GT.0 .AND. KRANK.LT.N) THEN + DO 140 I = KRANK,1,-1 + CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), + + W(MAP1,1), MDW, 1, MG) + 140 CONTINUE + ENDIF +C +C Compute permuted inequality constraint matrix times r-inv. +C + DO 160 I = MAP1,M + DO 150 J = 1,KRANK + W(I,J) = (W(I,J)-DDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J) + 150 CONTINUE + 160 CONTINUE + ENDIF +C +C Solve the reduced problem with DLPDP algorithm, +C the least projected distance problem. +C + CALL DLPDP(W(MAP1,1), MDW, MG, KRANK, N-KRANK, PRGOPT, X, + + XNORM, MDLPDP, WS(N2), IP(N+1)) +C +C Compute solution in original coordinates. +C + IF (MDLPDP.EQ.1) THEN + DO 170 I = KRANK,1,-1 + X(I) = (X(I)-DDOT(KRANK-I,W(I,I+1),MDW,X(I+1),1))/W(I,I) + 170 CONTINUE +C +C Apply Householder transformation to solution vector. +C + IF (KRANK.LT.N) THEN + DO 180 I = 1,KRANK + CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), + + X, 1, 1, 1) + 180 CONTINUE + ENDIF +C +C Repermute variables to their input order. +C + IF (MINMAN.GT.0) THEN + DO 190 I = MINMAN,1,-1 + CALL DSWAP (1, X(I), 1, X(IP(I)), 1) + 190 CONTINUE +C +C Variables are now in original coordinates. +C Add solution of unconstrained problem. +C + DO 200 I = 1,N + X(I) = X(I) + WS(I) + 200 CONTINUE +C +C Compute the residual vector norm. +C + RNORM = SQRT(RNORM**2+XNORM**2) + ENDIF + ELSE + MODE = 2 + ENDIF + ELSE + CALL DCOPY (N, WS, 1, X, 1) + ENDIF +C +C Compute covariance matrix based on the orthogonal decomposition +C from DHFTI( ). +C + IF (.NOT.COV .OR. KRANK.LE.0) GO TO 370 + KRM1 = KRANK - 1 + KRP1 = KRANK + 1 +C +C Copy diagonal terms to working array. +C + CALL DCOPY (KRANK, W, MDW+1, WS(N2), 1) +C +C Reciprocate diagonal terms. +C + DO 210 J = 1,KRANK + W(J,J) = 1.D0/W(J,J) + 210 CONTINUE +C +C Invert the upper triangular QR factor on itself. +C + IF (KRANK.GT.1) THEN + DO 230 I = 1,KRM1 + DO 220 J = I+1,KRANK + W(I,J) = -DDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J) + 220 CONTINUE + 230 CONTINUE + ENDIF +C +C Compute the inverted factor times its transpose. +C + DO 250 I = 1,KRANK + DO 240 J = I,KRANK + W(I,J) = DDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW) + 240 CONTINUE + 250 CONTINUE +C +C Zero out lower trapezoidal part. +C Copy upper triangular to lower triangular part. +C + IF (KRANK.LT.N) THEN + DO 260 J = 1,KRANK + CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) + 260 CONTINUE +C + DO 270 I = KRP1,N + CALL DCOPY (I, 0.D0, 0, W(I,1), MDW) + 270 CONTINUE +C +C Apply right side transformations to lower triangle. +C + N3 = N2 + KRP1 + DO 330 I = 1,KRANK + L = N1 + I + K = N2 + I + RB = WS(L-1)*WS(K-1) +C +C If RB.GE.0.D0, transformation can be regarded as zero. +C + IF (RB.LT.0.D0) THEN + RB = 1.D0/RB +C +C Store unscaled rank one Householder update in work array. +C + CALL DCOPY (N, 0.D0, 0, WS(N3), 1) + L = N1 + I + K = N3 + I + WS(K-1) = WS(L-1) +C + DO 280 J = KRP1,N + WS(N3+J-1) = W(I,J) + 280 CONTINUE +C + DO 290 J = 1,N + WS(J) = RB*(DDOT(J-I,W(J,I),MDW,WS(N3+I-1),1)+ + + DDOT(N-J+1,W(J,J),1,WS(N3+J-1),1)) + 290 CONTINUE +C + L = N3 + I + GAM = 0.5D0*RB*DDOT(N-I+1,WS(L-1),1,WS(I),1) + CALL DAXPY (N-I+1, GAM, WS(L-1), 1, WS(I), 1) + DO 320 J = I,N + DO 300 L = 1,I-1 + W(J,L) = W(J,L) + WS(N3+J-1)*WS(L) + 300 CONTINUE +C + DO 310 L = I,J + W(J,L) = W(J,L) + WS(J)*WS(N3+L-1)+WS(L)*WS(N3+J-1) + 310 CONTINUE + 320 CONTINUE + ENDIF + 330 CONTINUE +C +C Copy lower triangle to upper triangle to symmetrize the +C covariance matrix. +C + DO 340 I = 1,N + CALL DCOPY (I, W(I,1), MDW, W(1,I), 1) + 340 CONTINUE + ENDIF +C +C Repermute rows and columns. +C + DO 350 I = MINMAN,1,-1 + K = IP(I) + IF (I.NE.K) THEN + CALL DSWAP (1, W(I,I), 1, W(K,K), 1) + CALL DSWAP (I-1, W(1,I), 1, W(1,K), 1) + CALL DSWAP (K-I-1, W(I,I+1), MDW, W(I+1,K), 1) + CALL DSWAP (N-K, W(I, K+1), MDW, W(K, K+1), MDW) + ENDIF + 350 CONTINUE +C +C Put in normalized residual sum of squares scale factor +C and symmetrize the resulting covariance matrix. +C + DO 360 J = 1,N + CALL DSCAL (J, FAC, W(1,J), 1) + CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) + 360 CONTINUE +C + 370 IP(1) = KRANK + IP(2) = N + MAX(M,N) + (MG+2)*(N+7) + RETURN + END +*DECK D1MACH + DOUBLE PRECISION FUNCTION D1MACH (I) +C***BEGIN PROLOGUE D1MACH +C***PURPOSE Return floating point machine dependent constants. +C***LIBRARY SLATEC +C***CATEGORY R1 +C***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) +C***KEYWORDS MACHINE CONSTANTS +C***AUTHOR Fox, P. A., (Bell Labs) +C Hall, A. D., (Bell Labs) +C Schryer, N. L., (Bell Labs) +C***DESCRIPTION +C +C D1MACH can be used to obtain machine-dependent parameters for the +C local machine environment. It is a function subprogram with one +C (input) argument, and can be referenced as follows: +C +C D = D1MACH(I) +C +C where I=1,...,5. The (output) value of D above is determined by +C the (input) value of I. The results for various values of I are +C discussed below. +C +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 Assume double precision numbers are represented in the T-digit, +C base-B form +C +C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and +C EMIN .LE. E .LE. EMAX. +C +C The values of B, T, EMIN and EMAX are provided in I1MACH as +C follows: +C I1MACH(10) = B, the base. +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 +C To alter this function for a particular environment, the desired +C set of DATA statements should be activated by removing the C from +C column 1. Also, the values of D1MACH(1) - D1MACH(4) should be +C checked for consistency with the local operating system. +C +C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +C a portable library, ACM Transactions on Mathematical +C Software 4, 2 (June 1978), pp. 177-188. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 890213 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900618 Added DEC RISC constants. (WRB) +C 900723 Added IBM RS 6000 constants. (WRB) +C 900911 Added SUN 386i constants. (WRB) +C 910710 Added HP 730 constants. (SMR) +C 911114 Added Convex IEEE constants. (WRB) +C 920121 Added SUN -r8 compiler option constants. (WRB) +C 920229 Added Touchstone Delta i860 constants. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 920625 Added CONVEX -p8 and -pd8 compiler option constants. +C (BKS, WRB) +C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) +C 010817 Elevated IEEE to highest importance; see next set of +C comments below. (DWL) +C***END PROLOGUE D1MACH +C + + INTEGER SMALL(4) + INTEGER LARGE(4) + INTEGER RIGHT(4) + INTEGER DIVER(4) + INTEGER LOG10(4) +C +C Initial data here correspond to the IEEE standard. The values for +C DMACH(1), DMACH(3) and DMACH(4) are slight upper bounds. The value +C for DMACH(2) is a slight lower bound. The value for DMACH(5) is +C a 20-digit approximation. If one of the sets of initial data below +C is preferred, do the necessary commenting and uncommenting. (DWL) + DOUBLE PRECISION DMACH(5) + DATA DMACH / 2.23D-308, 1.79D+308, 1.111D-16, 2.222D-16, + 1 0.30102999566398119521D0 / + SAVE DMACH +C + 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 AMIGA +C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE APOLLO +C +C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / +C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / +C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / +C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM +C +C DATA SMALL(1) / ZC00800000 / +C DATA SMALL(2) / Z000000000 / +C DATA LARGE(1) / ZDFFFFFFFF / +C DATA LARGE(2) / ZFFFFFFFFF / +C DATA RIGHT(1) / ZCC5800000 / +C DATA RIGHT(2) / Z000000000 / +C DATA DIVER(1) / ZCC6800000 / +C DATA DIVER(2) / Z000000000 / +C DATA LOG10(1) / ZD00E730E7 / +C DATA LOG10(2) / ZC77800DC0 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O0000000000000000 / +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O0007777777777777 / +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O7770000000000000 / +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O7777777777777777 / +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 / +C +C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE +C +C DATA SMALL(1) / Z"3001800000000000" / +C DATA SMALL(2) / Z"3001000000000000" / +C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / +C DATA LARGE(2) / Z"4FFE000000000000" / +C DATA RIGHT(1) / Z"3FD2800000000000" / +C DATA RIGHT(2) / Z"3FD2000000000000" / +C DATA DIVER(1) / Z"3FD3800000000000" / +C DATA DIVER(2) / Z"3FD3000000000000" / +C DATA LOG10(1) / Z"3FFF9A209A84FBCF" / +C DATA LOG10(2) / Z"3FFFF7988F8959AC" / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES +C +C DATA SMALL(1) / 00564000000000000000B / +C DATA SMALL(2) / 00000000000000000000B / +C DATA LARGE(1) / 37757777777777777777B / +C DATA LARGE(2) / 37157777777777777777B / +C DATA RIGHT(1) / 15624000000000000000B / +C DATA RIGHT(2) / 00000000000000000000B / +C DATA DIVER(1) / 15634000000000000000B / +C DATA DIVER(2) / 00000000000000000000B / +C DATA LOG10(1) / 17164642023241175717B / +C DATA LOG10(2) / 16367571421742254654B / +C +C MACHINE CONSTANTS FOR THE CELERITY C1260 +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fn OR -pd8 COMPILER OPTION +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CC0000000000000' / +C DATA DMACH(4) / Z'3CD0000000000000' / +C DATA DMACH(5) / Z'3FF34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fi COMPILER OPTION +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -p8 COMPILER OPTION +C +C DATA DMACH(1) / Z'00010000000000000000000000000000' / +C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3F900000000000000000000000000000' / +C DATA DMACH(4) / Z'3F910000000000000000000000000000' / +C DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / +C +C MACHINE CONSTANTS FOR THE CRAY +C +C DATA SMALL(1) / 201354000000000000000B / +C DATA SMALL(2) / 000000000000000000000B / +C DATA LARGE(1) / 577767777777777777777B / +C DATA LARGE(2) / 000007777777777777774B / +C DATA RIGHT(1) / 376434000000000000000B / +C DATA RIGHT(2) / 000000000000000000000B / +C DATA DIVER(1) / 376444000000000000000B / +C DATA DIVER(2) / 000000000000000000000B / +C DATA LOG10(1) / 377774642023241175717B / +C DATA LOG10(2) / 000007571421742254654B / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - +C STATIC DMACH(5) +C +C DATA SMALL / 20K, 3*0 / +C DATA LARGE / 77777K, 3*177777K / +C DATA RIGHT / 31420K, 3*0 / +C DATA DIVER / 32020K, 3*0 / +C DATA LOG10 / 40423K, 42023K, 50237K, 74776K / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING G_FLOAT +C +C DATA DMACH(1) / '0000000000000010'X / +C DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / +C DATA DMACH(3) / '0000000000003CC0'X / +C DATA DMACH(4) / '0000000000003CD0'X / +C DATA DMACH(5) / '79FF509F44133FF3'X / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING IEEE_FORMAT +C +C DATA DMACH(1) / '0010000000000000'X / +C DATA DMACH(2) / '7FEFFFFFFFFFFFFF'X / +C DATA DMACH(3) / '3CA0000000000000'X / +C DATA DMACH(4) / '3CB0000000000000'X / +C DATA DMACH(5) / '3FD34413509F79FF'X / +C +C MACHINE CONSTANTS FOR THE DEC RISC +C +C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ +C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ +C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ +C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ +C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING D_FLOATING +C (EXPRESSED IN INTEGER AND HEXADECIMAL) +C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS +C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS +C +C DATA SMALL(1), SMALL(2) / 128, 0 / +C DATA LARGE(1), LARGE(2) / -32769, -1 / +C DATA RIGHT(1), RIGHT(2) / 9344, 0 / +C DATA DIVER(1), DIVER(2) / 9472, 0 / +C DATA LOG10(1), LOG10(2) / 546979738, -805796613 / +C +C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / +C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING G_FLOATING +C (EXPRESSED IN INTEGER AND HEXADECIMAL) +C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS +C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS +C +C DATA SMALL(1), SMALL(2) / 16, 0 / +C DATA LARGE(1), LARGE(2) / -32769, -1 / +C DATA RIGHT(1), RIGHT(2) / 15552, 0 / +C DATA DIVER(1), DIVER(2) / 15568, 0 / +C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / +C +C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / +C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / +C +C MACHINE CONSTANTS FOR THE ELXSI 6400 +C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) +C +C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / +C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / +C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / +C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / +C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / +C +C MACHINE CONSTANTS FOR THE HARRIS 220 +C +C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / +C DATA LARGE(1), LARGE(2) / '37777777, '37777577 / +C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / +C DATA DIVER(1), DIVER(2) / '20000000, '00000334 / +C DATA LOG10(1), LOG10(2) / '23210115, '10237777 / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES +C +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 / +C +C MACHINE CONSTANTS FOR THE HP 730 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / +C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / +C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / +C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / +C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA SMALL(1), SMALL(2) / 40000B, 0 / +C DATA SMALL(3), SMALL(4) / 0, 1 / +C DATA LARGE(1), LARGE(2) / 77777B, 177777B / +C DATA LARGE(3), LARGE(4) / 177777B, 177776B / +C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / +C DATA RIGHT(3), RIGHT(4) / 0, 225B / +C DATA DIVER(1), DIVER(2) / 40000B, 0 / +C DATA DIVER(3), DIVER(4) / 0, 227B / +C DATA LOG10(1), LOG10(2) / 46420B, 46502B / +C DATA LOG10(3), LOG10(4) / 76747B, 176377B / +C +C MACHINE CONSTANTS FOR THE HP 9000 +C +C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / +C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / +C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / +C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / +C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND +C THE PERKIN ELMER (INTERDATA) 7/32. +C +C DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / +C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / +C +C MACHINE CONSTANTS FOR THE IBM PC +C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION +C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. +C +C DATA SMALL(1) / 2.23D-308 / +C DATA LARGE(1) / 1.79D+308 / +C DATA RIGHT(1) / 1.11D-16 / +C DATA DIVER(1) / 2.22D-16 / +C DATA LOG10(1) / 0.301029995663981195D0 / +C +C MACHINE CONSTANTS FOR THE IBM RS 6000 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE INTEL i860 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) +C +C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / +C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / +C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / +C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / +C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) +C +C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / +C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / +C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / +C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / +C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +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 / +C +C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / +C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / +C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / +C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / +C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA SMALL(1), SMALL(2) / 128, 0 / +C DATA SMALL(3), SMALL(4) / 0, 0 / +C DATA LARGE(1), LARGE(2) / 32767, -1 / +C DATA LARGE(3), LARGE(4) / -1, -1 / +C DATA RIGHT(1), RIGHT(2) / 9344, 0 / +C DATA RIGHT(3), RIGHT(4) / 0, 0 / +C DATA DIVER(1), DIVER(2) / 9472, 0 / +C DATA DIVER(3), DIVER(4) / 0, 0 / +C DATA LOG10(1), LOG10(2) / 16282, 8346 / +C DATA LOG10(3), LOG10(4) / -31493, -12296 / +C +C DATA SMALL(1), SMALL(2) / O000200, O000000 / +C DATA SMALL(3), SMALL(4) / O000000, O000000 / +C DATA LARGE(1), LARGE(2) / O077777, O177777 / +C DATA LARGE(3), LARGE(4) / O177777, O177777 / +C DATA RIGHT(1), RIGHT(2) / O022200, O000000 / +C DATA RIGHT(3), RIGHT(4) / O000000, O000000 / +C DATA DIVER(1), DIVER(2) / O022400, O000000 / +C DATA DIVER(3), DIVER(4) / O000000, O000000 / +C DATA LOG10(1), LOG10(2) / O037632, O020232 / +C DATA LOG10(3), LOG10(4) / O102373, O147770 / +C +C MACHINE CONSTANTS FOR THE SILICON GRAPHICS +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE SUN +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE SUN +C USING THE -r8 COMPILER OPTION +C +C DATA DMACH(1) / Z'00010000000000000000000000000000' / +C DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / +C DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / +C DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / +C +C MACHINE CONSTANTS FOR THE SUN 386i +C +C DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / +C DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / +C DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' +C DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER +C +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 / +C +C***FIRST EXECUTABLE STATEMENT D1MACH +C IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'D1MACH', +C + 'I OUT OF BOUNDS', 1, 2) +C + D1MACH = DMACH(I) + RETURN +C + END +*DECK I1MACH + INTEGER FUNCTION I1MACH (I) +C***BEGIN PROLOGUE I1MACH +C***PURPOSE Return integer machine dependent constants. +C***LIBRARY SLATEC +C***CATEGORY R1 +C***TYPE INTEGER (I1MACH-I) +C***KEYWORDS MACHINE CONSTANTS +C***AUTHOR Fox, P. A., (Bell Labs) +C Hall, A. D., (Bell Labs) +C Schryer, N. L., (Bell Labs) +C***DESCRIPTION +C +C I1MACH can be used to obtain machine-dependent parameters for the +C local machine environment. It is a function subprogram with one +C (input) argument and can be referenced as follows: +C +C K = I1MACH(I) +C +C where I=1,...,16. The (output) value of K above is determined by +C the (input) value of I. The results for various values of I are +C discussed below. +C +C I/O unit numbers: +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 +C Words: +C I1MACH( 5) = the number of bits per integer storage unit. +C I1MACH( 6) = the number of characters per integer storage unit. +C +C Integers: +C assume integers are represented in the S-digit, base-A form +C +C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) +C +C where 0 .LE. X(I) .LT. A for I=0,...,S-1. +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 +C Floating-Point Numbers: +C Assume floating-point numbers are represented in the T-digit, +C base-B form +C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C where 0 .LE. X(I) .LT. B for I=1,...,T, +C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. +C I1MACH(10) = B, the base. +C +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 +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 +C To alter this function for a particular environment, the desired +C set of DATA statements should be activated by removing the C from +C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be +C checked for consistency with the local operating system. +C +C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +C a portable library, ACM Transactions on Mathematical +C Software 4, 2 (June 1978), pp. 177-188. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 891012 Added VAX G-floating constants. (WRB) +C 891012 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900618 Added DEC RISC constants. (WRB) +C 900723 Added IBM RS 6000 constants. (WRB) +C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. +C (RWC) +C 910710 Added HP 730 constants. (SMR) +C 911114 Added Convex IEEE constants. (WRB) +C 920121 Added SUN -r8 compiler option constants. (WRB) +C 920229 Added Touchstone Delta i860 constants. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 920625 Added Convex -p8 and -pd8 compiler option constants. +C (BKS, WRB) +C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) +C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler +C options. (DWL, RWC and WRB). +C 010817 Elevated IEEE to highest importance; see next set of +C comments below. (DWL) +C***END PROLOGUE I1MACH +C +C Initial data here correspond to the IEEE standard. If one of the +C sets of initial data below is preferred, do the necessary commenting +C and uncommenting. (DWL) + INTEGER IMACH(16),OUTPUT + DATA IMACH( 1) / 5 / + DATA IMACH( 2) / 6 / + DATA IMACH( 3) / 6 / + DATA IMACH( 4) / 6 / + DATA IMACH( 5) / 32 / + DATA IMACH( 6) / 4 / + DATA IMACH( 7) / 2 / + DATA IMACH( 8) / 31 / + DATA IMACH( 9) / 2147483647 / + DATA IMACH(10) / 2 / + DATA IMACH(11) / 24 / + DATA IMACH(12) / -126 / + DATA IMACH(13) / 127 / + DATA IMACH(14) / 53 / + DATA IMACH(15) / -1022 / + DATA IMACH(16) / 1023 / + SAVE IMACH + EQUIVALENCE (IMACH(4),OUTPUT) +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT COMPILER +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE APOLLO +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 129 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1025 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM +C +C DATA IMACH( 1) / 7 / +C DATA IMACH( 2) / 2 / +C DATA IMACH( 3) / 2 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 33 / +C DATA IMACH( 9) / Z1FFFFFFFF / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -256 / +C DATA IMACH(13) / 255 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) / -256 / +C DATA IMACH(16) / 255 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM +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) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -50 / +C DATA IMACH(16) / 76 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS +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) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -32754 / +C DATA IMACH(16) / 32780 / +C +C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE +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) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -4095 / +C DATA IMACH(13) / 4094 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -4095 / +C DATA IMACH(16) / 4094 / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6LOUTPUT/ +C DATA IMACH( 5) / 60 / +C DATA IMACH( 6) / 10 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 48 / +C DATA IMACH( 9) / 00007777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -929 / +C DATA IMACH(13) / 1070 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -929 / +C DATA IMACH(16) / 1069 / +C +C MACHINE CONSTANTS FOR THE CELERITY C1260 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 0 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / Z'7FFFFFFF' / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fn COMPILER OPTION +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) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fi COMPILER OPTION +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -p8 COMPILER OPTION +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) / 64 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1023 / +C DATA IMACH(13) / 1023 / +C DATA IMACH(14) / 113 / +C DATA IMACH(15) / -16383 / +C DATA IMACH(16) / 16383 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -pd8 COMPILER OPTION +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) / 64 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1023 / +C DATA IMACH(13) / 1023 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CRAY +C USING THE 46 BIT INTEGER COMPILER OPTION +C +C DATA IMACH( 1) / 100 / +C DATA IMACH( 2) / 101 / +C DATA IMACH( 3) / 102 / +C DATA IMACH( 4) / 101 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 46 / +C DATA IMACH( 9) / 1777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -8189 / +C DATA IMACH(13) / 8190 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -8099 / +C DATA IMACH(16) / 8190 / +C +C MACHINE CONSTANTS FOR THE CRAY +C USING THE 64 BIT INTEGER COMPILER OPTION +C +C DATA IMACH( 1) / 100 / +C DATA IMACH( 2) / 101 / +C DATA IMACH( 3) / 102 / +C DATA IMACH( 4) / 101 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 777777777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -8189 / +C DATA IMACH(13) / 8190 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -8099 / +C DATA IMACH(16) / 8190 / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C +C DATA IMACH( 1) / 11 / +C DATA IMACH( 2) / 12 / +C DATA IMACH( 3) / 8 / +C DATA IMACH( 4) / 10 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING G_FLOAT +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING IEEE_FLOAT +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE DEC RISC +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING D_FLOATING +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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 / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING G_FLOATING +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE ELXSI 6400 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 32 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE HARRIS 220 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / 3 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 23 / +C DATA IMACH( 9) / 8388607 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 38 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 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) / 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) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 63 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 730 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 4 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 39 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 4 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 55 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 9000 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 7 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 32 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1015 / +C DATA IMACH(16) / 1017 / +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND +C THE PERKIN ELMER (INTERDATA) 7/32. +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) / Z7FFFFFFF / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 / +C +C MACHINE CONSTANTS FOR THE IBM PC +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 0 / +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) / -125 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE IBM RS 6000 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 0 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE INTEL i860 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 54 / +C DATA IMACH(15) / -101 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 62 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 16-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +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 / +C +C MACHINE CONSTANTS FOR THE SILICON GRAPHICS +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE SUN +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE SUN +C USING THE -r8 COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / 53 / +C DATA IMACH(12) / -1021 / +C DATA IMACH(13) / 1024 / +C DATA IMACH(14) / 113 / +C DATA IMACH(15) / -16381 / +C DATA IMACH(16) / 16384 / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 1 / +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) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) / -1024 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR +C +C DATA IMACH( 1) / 1 / +C DATA IMACH( 2) / 1 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +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 / +C +C***FIRST EXECUTABLE STATEMENT I1MACH + IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 +C + I1MACH = IMACH(I) + RETURN +C + 10 CONTINUE + WRITE (UNIT = OUTPUT, FMT = 9000) + 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') +C +C CALL FDUMP +C + STOP + END +*DECK DH12 + SUBROUTINE DH12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV, + + NCV) +C***BEGIN PROLOGUE DH12 +C***SUBSIDIARY +C***PURPOSE Subsidiary to DHFTI, DLSEI and DWNNLS +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (H12-S, DH12-D) +C***AUTHOR (UNKNOWN) +C***DESCRIPTION +C +C *** DOUBLE PRECISION VERSION OF H12 ****** +C +C C.L.Lawson and R.J.Hanson, Jet Propulsion Laboratory, 1973 Jun 12 +C to appear in 'Solving Least Squares Problems', Prentice-Hall, 1974 +C +C Construction and/or application of a single +C Householder transformation.. Q = I + U*(U**T)/B +C +C MODE = 1 or 2 to select algorithm H1 or H2 . +C LPIVOT is the index of the pivot element. +C L1,M If L1 .LE. M the transformation will be constructed to +C zero elements indexed from L1 through M. If L1 GT. M +C THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. +C U(),IUE,UP On entry to H1 U() contains the pivot vector. +C IUE is the storage increment between elements. +C On exit from H1 U() and UP +C contain quantities defining the vector U of the +C Householder transformation. On entry to H2 U() +C and UP should contain quantities previously computed +C by H1. These will not be modified by H2. +C C() On entry to H1 or H2 C() contains a matrix which will be +C regarded as a set of vectors to which the Householder +C transformation is to be applied. On exit C() contains the +C set of transformed vectors. +C ICE Storage increment between elements of vectors in C(). +C ICV Storage increment between vectors in C(). +C NCV Number of vectors in C() to be transformed. If NCV .LE. 0 +C no operations will be done on C(). +C +C***SEE ALSO DHFTI, DLSEI, DWNNLS +C***ROUTINES CALLED DAXPY, DDOT, DSWAP +C***REVISION HISTORY (YYMMDD) +C 790101 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900911 Added DDOT to DOUBLE PRECISION statement. (WRB) +C***END PROLOGUE DH12 + + INTEGER I, I2, I3, I4, ICE, ICV, INCR, IUE, J, KL1, KL2, KLP, + * L1, L1M1, LPIVOT, M, MML1P2, MODE, NCV + DOUBLE PRECISION B, C, CL, CLINV, ONE, UL1M1, SM, U, UP, DDOT + DIMENSION U(IUE,*), C(*) +C BEGIN BLOCK PERMITTING ...EXITS TO 140 +C***FIRST EXECUTABLE STATEMENT DH12 + ONE = 1.0D0 +C +C ...EXIT + IF (0 .GE. LPIVOT .OR. LPIVOT .GE. L1 .OR. L1 .GT. M) GO TO 140 + CL = ABS(U(1,LPIVOT)) + IF (MODE .EQ. 2) GO TO 40 +C ****** CONSTRUCT THE TRANSFORMATION. ****** + DO 10 J = L1, M + CL = MAX(ABS(U(1,J)),CL) + 10 CONTINUE + IF (CL .GT. 0.0D0) GO TO 20 +C .........EXIT + GO TO 140 + 20 CONTINUE + CLINV = ONE/CL + SM = (U(1,LPIVOT)*CLINV)**2 + DO 30 J = L1, M + SM = SM + (U(1,J)*CLINV)**2 + 30 CONTINUE + CL = CL*SQRT(SM) + IF (U(1,LPIVOT) .GT. 0.0D0) CL = -CL + UP = U(1,LPIVOT) - CL + U(1,LPIVOT) = CL + GO TO 50 + 40 CONTINUE +C ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** +C + IF (CL .GT. 0.0D0) GO TO 50 +C ......EXIT + GO TO 140 + 50 CONTINUE +C ...EXIT + IF (NCV .LE. 0) GO TO 140 + B = UP*U(1,LPIVOT) +C B MUST BE NONPOSITIVE HERE. IF B = 0., RETURN. +C + IF (B .LT. 0.0D0) GO TO 60 +C ......EXIT + GO TO 140 + 60 CONTINUE + B = ONE/B + MML1P2 = M - L1 + 2 + IF (MML1P2 .LE. 20) GO TO 80 + L1M1 = L1 - 1 + KL1 = 1 + (L1M1 - 1)*ICE + KL2 = KL1 + KLP = 1 + (LPIVOT - 1)*ICE + UL1M1 = U(1,L1M1) + U(1,L1M1) = UP + IF (LPIVOT .NE. L1M1) CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) + DO 70 J = 1, NCV + SM = DDOT(MML1P2,U(1,L1M1),IUE,C(KL1),ICE) + SM = SM*B + CALL DAXPY(MML1P2,SM,U(1,L1M1),IUE,C(KL1),ICE) + KL1 = KL1 + ICV + 70 CONTINUE + U(1,L1M1) = UL1M1 +C ......EXIT + IF (LPIVOT .EQ. L1M1) GO TO 140 + KL1 = KL2 + CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) + GO TO 130 + 80 CONTINUE + I2 = 1 - ICV + ICE*(LPIVOT - 1) + INCR = ICE*(L1 - LPIVOT) + DO 120 J = 1, NCV + I2 = I2 + ICV + I3 = I2 + INCR + I4 = I3 + SM = C(I2)*UP + DO 90 I = L1, M + SM = SM + C(I3)*U(1,I) + I3 = I3 + ICE + 90 CONTINUE + IF (SM .EQ. 0.0D0) GO TO 110 + SM = SM*B + C(I2) = C(I2) + SM*UP + DO 100 I = L1, M + C(I4) = C(I4) + SM*U(1,I) + I4 = I4 + ICE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + RETURN + END +*DECK DHFTI + SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, + + G, IP) +C***BEGIN PROLOGUE DHFTI +C***PURPOSE Solve a least squares problem for banded matrices using +C sequential accumulation of rows of the data matrix. +C Exactly one right-hand side vector is permitted. +C***LIBRARY SLATEC +C***CATEGORY D9 +C***TYPE DOUBLE PRECISION (HFTI-S, DHFTI-D) +C***KEYWORDS CURVE FITTING, LEAST SQUARES +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C***DESCRIPTION +C +C DIMENSION A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N) +C +C This subroutine solves a linear least squares problem or a set of +C linear least squares problems having the same matrix but different +C right-side vectors. The problem data consists of an M by N matrix +C A, an M by NB matrix B, and an absolute tolerance parameter TAU +C whose usage is described below. The NB column vectors of B +C represent right-side vectors for NB distinct linear least squares +C problems. +C +C This set of problems can also be written as the matrix least +C squares problem +C +C AX = B, +C +C where X is the N by NB solution matrix. +C +C Note that if B is the M by M identity matrix, then X will be the +C pseudo-inverse of A. +C +C This subroutine first transforms the augmented matrix (A B) to a +C matrix (R C) using premultiplying Householder transformations with +C column interchanges. All subdiagonal elements in the matrix R are +C zero and its diagonal elements satisfy +C +C ABS(R(I,I)).GE.ABS(R(I+1,I+1)), +C +C I = 1,...,L-1, where +C +C L = MIN(M,N). +C +C The subroutine will compute an integer, KRANK, equal to the number +C of diagonal terms of R that exceed TAU in magnitude. Then a +C solution of minimum Euclidean length is computed using the first +C KRANK rows of (R C). +C +C To be specific we suggest that the user consider an easily +C computable matrix norm, such as, the maximum of all column sums of +C magnitudes. +C +C Now if the relative uncertainty of B is EPS, (norm of uncertainty/ +C norm of B), it is suggested that TAU be set approximately equal to +C EPS*(norm of A). +C +C The user must dimension all arrays appearing in the call list.. +C A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N). This +C permits the solution of a range of problems in the same array +C space. +C +C The entire set of parameters for DHFTI are +C +C INPUT.. All TYPE REAL variables are DOUBLE PRECISION +C +C A(*,*),MDA,M,N The array A(*,*) initially contains the M by N +C matrix A of the least squares problem AX = B. +C The first dimensioning parameter of the array +C A(*,*) is MDA, which must satisfy MDA.GE.M +C Either M.GE.N or M.LT.N is permitted. There +C is no restriction on the rank of A. The +C condition MDA.LT.M is considered an error. +C +C B(*),MDB,NB If NB = 0 the subroutine will perform the +C orthogonal decomposition but will make no +C references to the array B(*). If NB.GT.0 +C the array B(*) must initially contain the M by +C NB matrix B of the least squares problem AX = +C B. If NB.GE.2 the array B(*) must be doubly +C subscripted with first dimensioning parameter +C MDB.GE.MAX(M,N). If NB = 1 the array B(*) may +C be either doubly or singly subscripted. In +C the latter case the value of MDB is arbitrary +C but it should be set to some valid integer +C value such as MDB = M. +C +C The condition of NB.GT.1.AND.MDB.LT. MAX(M,N) +C is considered an error. +C +C TAU Absolute tolerance parameter provided by user +C for pseudorank determination. +C +C H(*),G(*),IP(*) Arrays of working space used by DHFTI. +C +C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION +C +C A(*,*) The contents of the array A(*,*) will be +C modified by the subroutine. These contents +C are not generally required by the user. +C +C B(*) On return the array B(*) will contain the N by +C NB solution matrix X. +C +C KRANK Set by the subroutine to indicate the +C pseudorank of A. +C +C RNORM(*) On return, RNORM(J) will contain the Euclidean +C norm of the residual vector for the problem +C defined by the J-th column vector of the array +C B(*,*) for J = 1,...,NB. +C +C H(*),G(*) On return these arrays respectively contain +C elements of the pre- and post-multiplying +C Householder transformations used to compute +C the minimum Euclidean length solution. +C +C IP(*) Array in which the subroutine records indices +C describing the permutation of column vectors. +C The contents of arrays H(*),G(*) and IP(*) +C are not generally required by the user. +C +C***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares +C Problems, Prentice-Hall, Inc., 1974, Chapter 14. +C***ROUTINES CALLED D1MACH, DH12, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790101 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 891006 Cosmetic changes to prologue. (WRB) +C 891006 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 901005 Replace usage of DDIFF with usage of D1MACH. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DHFTI + + INTEGER I, II, IOPT, IP(*), IP1, J, JB, JJ, K, KP1, KRANK, L, + * LDIAG, LMAX, M, MDA, MDB, N, NB, NERR + DOUBLE PRECISION A, B, D1MACH, DZERO, FACTOR, + * G, H, HMAX, RELEPS, RNORM, SM, SM1, SZERO, TAU, TMP + DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*) + SAVE RELEPS + DATA RELEPS /0.D0/ +C BEGIN BLOCK PERMITTING ...EXITS TO 360 +C***FIRST EXECUTABLE STATEMENT DHFTI + IF (RELEPS.EQ.0.D0) RELEPS = D1MACH(4) + SZERO = 0.0D0 + DZERO = 0.0D0 + FACTOR = 0.001D0 +C + K = 0 + LDIAG = MIN(M,N) + IF (LDIAG .LE. 0) GO TO 350 +C BEGIN BLOCK PERMITTING ...EXITS TO 130 +C BEGIN BLOCK PERMITTING ...EXITS TO 120 + IF (MDA .GE. M) GO TO 10 + NERR = 1 + IOPT = 2 +C CALL XERMSG ('SLATEC', 'DHFTI', +C + 'MDA.LT.M, PROBABLE ERROR.', +C + NERR, IOPT) +C ...............EXIT + GO TO 360 + 10 CONTINUE +C + IF (NB .LE. 1 .OR. MAX(M,N) .LE. MDB) GO TO 20 + NERR = 2 + IOPT = 2 +C CALL XERMSG ('SLATEC', 'DHFTI', +C + 'MDB.LT.MAX(M,N).AND.NB.GT.1. PROBABLE ERROR.', +C + NERR, IOPT) +C ...............EXIT + GO TO 360 + 20 CONTINUE +C + DO 100 J = 1, LDIAG +C BEGIN BLOCK PERMITTING ...EXITS TO 70 + IF (J .EQ. 1) GO TO 40 +C +C UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX +C .. + LMAX = J + DO 30 L = J, N + H(L) = H(L) - A(J-1,L)**2 + IF (H(L) .GT. H(LMAX)) LMAX = L + 30 CONTINUE +C ......EXIT + IF (FACTOR*H(LMAX) .GT. HMAX*RELEPS) GO TO 70 + 40 CONTINUE +C +C COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX +C .. + LMAX = J + DO 60 L = J, N + H(L) = 0.0D0 + DO 50 I = J, M + H(L) = H(L) + A(I,L)**2 + 50 CONTINUE + IF (H(L) .GT. H(LMAX)) LMAX = L + 60 CONTINUE + HMAX = H(LMAX) + 70 CONTINUE +C .. +C LMAX HAS BEEN DETERMINED +C +C DO COLUMN INTERCHANGES IF NEEDED. +C .. + IP(J) = LMAX + IF (IP(J) .EQ. J) GO TO 90 + DO 80 I = 1, M + TMP = A(I,J) + A(I,J) = A(I,LMAX) + A(I,LMAX) = TMP + 80 CONTINUE + H(LMAX) = H(J) + 90 CONTINUE +C +C COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A +C AND B. +C .. + CALL DH12(1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA, + * N-J) + CALL DH12(2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB) + 100 CONTINUE +C +C DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, +C TAU. +C .. + DO 110 J = 1, LDIAG +C ......EXIT + IF (ABS(A(J,J)) .LE. TAU) GO TO 120 + 110 CONTINUE + K = LDIAG +C ......EXIT + GO TO 130 + 120 CONTINUE + K = J - 1 + 130 CONTINUE + KP1 = K + 1 +C +C COMPUTE THE NORMS OF THE RESIDUAL VECTORS. +C + IF (NB .LT. 1) GO TO 170 + DO 160 JB = 1, NB + TMP = SZERO + IF (M .LT. KP1) GO TO 150 + DO 140 I = KP1, M + TMP = TMP + B(I,JB)**2 + 140 CONTINUE + 150 CONTINUE + RNORM(JB) = SQRT(TMP) + 160 CONTINUE + 170 CONTINUE +C SPECIAL FOR PSEUDORANK = 0 + IF (K .GT. 0) GO TO 210 + IF (NB .LT. 1) GO TO 200 + DO 190 JB = 1, NB + DO 180 I = 1, N + B(I,JB) = SZERO + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + GO TO 340 + 210 CONTINUE +C +C IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER +C DECOMPOSITION OF FIRST K ROWS. +C .. + IF (K .EQ. N) GO TO 230 + DO 220 II = 1, K + I = KP1 - II + CALL DH12(1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1) + 220 CONTINUE + 230 CONTINUE +C +C + IF (NB .LT. 1) GO TO 330 + DO 320 JB = 1, NB +C +C SOLVE THE K BY K TRIANGULAR SYSTEM. +C .. + DO 260 L = 1, K + SM = DZERO + I = KP1 - L + IP1 = I + 1 + IF (K .LT. IP1) GO TO 250 + DO 240 J = IP1, K + SM = SM + A(I,J)*B(J,JB) + 240 CONTINUE + 250 CONTINUE + SM1 = SM + B(I,JB) = (B(I,JB) - SM1)/A(I,I) + 260 CONTINUE +C +C COMPLETE COMPUTATION OF SOLUTION VECTOR. +C .. + IF (K .EQ. N) GO TO 290 + DO 270 J = KP1, N + B(J,JB) = SZERO + 270 CONTINUE + DO 280 I = 1, K + CALL DH12(2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1, + * MDB,1) + 280 CONTINUE + 290 CONTINUE +C +C RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE +C COLUMN INTERCHANGES. +C .. + DO 310 JJ = 1, LDIAG + J = LDIAG + 1 - JJ + IF (IP(J) .EQ. J) GO TO 300 + L = IP(J) + TMP = B(L,JB) + B(L,JB) = B(J,JB) + B(J,JB) = TMP + 300 CONTINUE + 310 CONTINUE + 320 CONTINUE + 330 CONTINUE + 340 CONTINUE + 350 CONTINUE +C .. +C THE SOLUTION VECTORS, X, ARE NOW +C IN THE FIRST N ROWS OF THE ARRAY B(,). +C + KRANK = K + 360 CONTINUE + RETURN + END +*DECK DLPDP + SUBROUTINE DLPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, + + IS) +C***BEGIN PROLOGUE DLPDP +C***SUBSIDIARY +C***PURPOSE Subsidiary to DLSEI +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (LPDP-S, DLPDP-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C **** Double Precision version of LPDP **** +C DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1), +C where N=N1+N2. This is a slight overestimate for WS(*). +C +C Determine an N1-vector W, and +C an N2-vector Z +C which minimizes the Euclidean length of W +C subject to G*W+H*Z .GE. Y. +C This is the least projected distance problem, LPDP. +C The matrices G and H are of respective +C dimensions M by N1 and M by N2. +C +C Called by subprogram DLSI( ). +C +C The matrix +C (G H Y) +C +C occupies rows 1,...,M and cols 1,...,N1+N2+1 of A(*,*). +C +C The solution (W) is returned in X(*). +C (Z) +C +C The value of MODE indicates the status of +C the computation after returning to the user. +C +C MODE=1 The solution was successfully obtained. +C +C MODE=2 The inequalities are inconsistent. +C +C***SEE ALSO DLSEI +C***ROUTINES CALLED DCOPY, DDOT, DNRM2, DSCAL, DWNNLS +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910408 Updated the AUTHOR section. (WRB) +C***END PROLOGUE DLPDP + +C + INTEGER I, IS(*), IW, IX, J, L, M, MDA, MODE, MODEW, N, N1, N2, + * NP1 + DOUBLE PRECISION A(MDA,*), DDOT, DNRM2, FAC, ONE, + * PRGOPT(*), RNORM, SC, WNORM, WS(*), X(*), YNORM, ZERO + SAVE ZERO, ONE, FAC + DATA ZERO,ONE /0.0D0,1.0D0/, FAC /0.1D0/ +C***FIRST EXECUTABLE STATEMENT DLPDP + N = N1 + N2 + MODE = 1 + IF (M .GT. 0) GO TO 20 + IF (N .LE. 0) GO TO 10 + X(1) = ZERO + CALL DCOPY(N,X,0,X,1) + 10 CONTINUE + WNORM = ZERO + GO TO 200 + 20 CONTINUE +C BEGIN BLOCK PERMITTING ...EXITS TO 190 + NP1 = N + 1 +C +C SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE. + DO 40 I = 1, M + SC = DNRM2(N,A(I,1),MDA) + IF (SC .EQ. ZERO) GO TO 30 + SC = ONE/SC + CALL DSCAL(NP1,SC,A(I,1),MDA) + 30 CONTINUE + 40 CONTINUE +C +C SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO). + YNORM = DNRM2(M,A(1,NP1),1) + IF (YNORM .EQ. ZERO) GO TO 50 + SC = ONE/YNORM + CALL DSCAL(M,SC,A(1,NP1),1) + 50 CONTINUE +C +C SCALE COLS OF MATRIX H. + J = N1 + 1 + 60 IF (J .GT. N) GO TO 70 + SC = DNRM2(M,A(1,J),1) + IF (SC .NE. ZERO) SC = ONE/SC + CALL DSCAL(M,SC,A(1,J),1) + X(J) = SC + J = J + 1 + GO TO 60 + 70 CONTINUE + IF (N1 .LE. 0) GO TO 130 +C +C COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*). + IW = 0 + DO 80 I = 1, M +C +C MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY. + CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) + IW = IW + N2 +C +C MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY. + CALL DCOPY(N1,A(I,1),MDA,WS(IW+1),1) + IW = IW + N1 +C +C MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY. + WS(IW+1) = A(I,NP1) + IW = IW + 1 + 80 CONTINUE + WS(IW+1) = ZERO + CALL DCOPY(N,WS(IW+1),0,WS(IW+1),1) + IW = IW + N + WS(IW+1) = ONE + IW = IW + 1 +C +C SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0. THE +C MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR +C F = TRANSPOSE OF (0,...,0,1). + IX = IW + 1 + IW = IW + M +C +C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF +C DWNNLS( ). + IS(1) = 0 + IS(2) = 0 + CALL DWNNLS(WS,NP1,N2,NP1-N2,M,0,PRGOPT,WS(IX),RNORM, + * MODEW,IS,WS(IW+1)) +C +C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W. + SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) + IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) + * GO TO 110 + SC = ONE/SC + DO 90 J = 1, N1 + X(J) = SC*DDOT(M,A(1,J),1,WS(IX),1) + 90 CONTINUE +C +C COMPUTE THE VECTOR Q=Y-GW. OVERWRITE Y WITH THIS +C VECTOR. + DO 100 I = 1, M + A(I,NP1) = A(I,NP1) - DDOT(N1,A(I,1),MDA,X,1) + 100 CONTINUE + GO TO 120 + 110 CONTINUE + MODE = 2 +C .........EXIT + GO TO 190 + 120 CONTINUE + 130 CONTINUE + IF (N2 .LE. 0) GO TO 180 +C +C COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*). + IW = 0 + DO 140 I = 1, M + CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) + IW = IW + N2 + WS(IW+1) = A(I,NP1) + IW = IW + 1 + 140 CONTINUE + WS(IW+1) = ZERO + CALL DCOPY(N2,WS(IW+1),0,WS(IW+1),1) + IW = IW + N2 + WS(IW+1) = ONE + IW = IW + 1 + IX = IW + 1 + IW = IW + M +C +C SOLVE RV=S SUBJECT TO V.GE.0. THE MATRIX R =(TRANSPOSE +C OF (H Q)), WHERE Q=Y-GW. THE (N2+1)-VECTOR S =(TRANSPOSE +C OF (0,...,0,1)). +C +C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF +C DWNNLS( ). + IS(1) = 0 + IS(2) = 0 + CALL DWNNLS(WS,N2+1,0,N2+1,M,0,PRGOPT,WS(IX),RNORM,MODEW, + * IS,WS(IW+1)) +C +C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z. + SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) + IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) + * GO TO 160 + SC = ONE/SC + DO 150 J = 1, N2 + L = N1 + J + X(L) = SC*DDOT(M,A(1,L),1,WS(IX),1)*X(L) + 150 CONTINUE + GO TO 170 + 160 CONTINUE + MODE = 2 +C .........EXIT + GO TO 190 + 170 CONTINUE + 180 CONTINUE +C +C ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION. + CALL DSCAL(N,YNORM,X,1) + WNORM = DNRM2(N1,X,1) + 190 CONTINUE + 200 CONTINUE + RETURN + END +*DECK DWNNLS + SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, + + IWORK, WORK) +C***BEGIN PROLOGUE DWNNLS +C***PURPOSE Solve a linearly constrained least squares problem with +C equality constraints and nonnegativity constraints on +C selected variables. +C***LIBRARY SLATEC +C***CATEGORY K1A2A +C***TYPE DOUBLE PRECISION (WNNLS-S, DWNNLS-D) +C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, +C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, +C NONNEGATIVITY CONSTRAINTS, QUADRATIC PROGRAMMING +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C Abstract +C +C This subprogram solves a linearly constrained least squares +C problem. Suppose there are given matrices E and A of +C respective dimensions ME by N and MA by N, and vectors F +C and B of respective lengths ME and MA. This subroutine +C solves the problem +C +C EX = F, (equations to be exactly satisfied) +C +C AX = B, (equations to be approximately satisfied, +C in the least squares sense) +C +C subject to components L+1,...,N nonnegative +C +C Any values ME.GE.0, MA.GE.0 and 0.LE. L .LE.N are permitted. +C +C The problem is reposed as problem DWNNLS +C +C (WT*E)X = (WT*F) +C ( A) ( B), (least squares) +C subject to components L+1,...,N nonnegative. +C +C The subprogram chooses the heavy weight (or penalty parameter) WT. +C +C The parameters for DWNNLS are +C +C INPUT.. All TYPE REAL variables are DOUBLE PRECISION +C +C W(*,*),MDW, The array W(*,*) is double subscripted with first +C ME,MA,N,L dimensioning parameter equal to MDW. For this +C discussion let us call M = ME + MA. Then MDW +C must satisfy MDW.GE.M. The condition MDW.LT.M +C is an error. +C +C The array W(*,*) contains the matrices and vectors +C +C (E F) +C (A B) +C +C in rows and columns 1,...,M and 1,...,N+1 +C respectively. Columns 1,...,L correspond to +C unconstrained variables X(1),...,X(L). The +C remaining variables are constrained to be +C nonnegative. The condition L.LT.0 or L.GT.N is +C an error. +C +C PRGOPT(*) This double precision array is the option vector. +C If the user is satisfied with the nominal +C subprogram features set +C +C PRGOPT(1)=1 (or PRGOPT(1)=1.0) +C +C Otherwise PRGOPT(*) is a linked list consisting of +C groups of data of the following form +C +C LINK +C KEY +C DATA SET +C +C The parameters LINK and KEY are each one word. +C The DATA SET can be comprised of several words. +C The number of items depends on the value of KEY. +C The value of LINK points to the first +C entry of the next group of data within +C PRGOPT(*). The exception is when there are +C no more options to change. In that +C case LINK=1 and the values KEY and DATA SET +C are not referenced. The general layout of +C PRGOPT(*) is as follows. +C +C ...PRGOPT(1)=LINK1 (link to first entry of next group) +C . PRGOPT(2)=KEY1 (key to the option change) +C . PRGOPT(3)=DATA VALUE (data value for this change) +C . . +C . . +C . . +C ...PRGOPT(LINK1)=LINK2 (link to the first entry of +C . next group) +C . PRGOPT(LINK1+1)=KEY2 (key to the option change) +C . PRGOPT(LINK1+2)=DATA VALUE +C ... . +C . . +C . . +C ...PRGOPT(LINK)=1 (no more options to change) +C +C Values of LINK that are nonpositive are errors. +C A value of LINK.GT.NLINK=100000 is also an error. +C This helps prevent using invalid but positive +C values of LINK that will probably extend +C beyond the program limits of PRGOPT(*). +C Unrecognized values of KEY are ignored. The +C order of the options is arbitrary and any number +C of options can be changed with the following +C restriction. To prevent cycling in the +C processing of the option array a count of the +C number of options changed is maintained. +C Whenever this count exceeds NOPT=1000 an error +C message is printed and the subprogram returns. +C +C OPTIONS.. +C +C KEY=6 +C Scale the nonzero columns of the +C entire data matrix +C (E) +C (A) +C to have length one. The DATA SET for +C this option is a single value. It must +C be nonzero if unit length column scaling is +C desired. +C +C KEY=7 +C Scale columns of the entire data matrix +C (E) +C (A) +C with a user-provided diagonal matrix. +C The DATA SET for this option consists +C of the N diagonal scaling factors, one for +C each matrix column. +C +C KEY=8 +C Change the rank determination tolerance from +C the nominal value of SQRT(SRELPR). This quantity +C can be no smaller than SRELPR, The arithmetic- +C storage precision. The quantity used +C here is internally restricted to be at +C least SRELPR. The DATA SET for this option +C is the new tolerance. +C +C KEY=9 +C Change the blow-up parameter from the +C nominal value of SQRT(SRELPR). The reciprocal of +C this parameter is used in rejecting solution +C components as too large when a variable is +C first brought into the active set. Too large +C means that the proposed component times the +C reciprocal of the parameter is not less than +C the ratio of the norms of the right-side +C vector and the data matrix. +C This parameter can be no smaller than SRELPR, +C the arithmetic-storage precision. +C +C For example, suppose we want to provide +C a diagonal matrix to scale the problem +C matrix and change the tolerance used for +C determining linear dependence of dropped col +C vectors. For these options the dimensions of +C PRGOPT(*) must be at least N+6. The FORTRAN +C statements defining these options would +C be as follows. +C +C PRGOPT(1)=N+3 (link to entry N+3 in PRGOPT(*)) +C PRGOPT(2)=7 (user-provided scaling key) +C +C CALL DCOPY(N,D,1,PRGOPT(3),1) (copy the N +C scaling factors from a user array called D(*) +C into PRGOPT(3)-PRGOPT(N+2)) +C +C PRGOPT(N+3)=N+6 (link to entry N+6 of PRGOPT(*)) +C PRGOPT(N+4)=8 (linear dependence tolerance key) +C PRGOPT(N+5)=... (new value of the tolerance) +C +C PRGOPT(N+6)=1 (no more options to change) +C +C +C IWORK(1), The amounts of working storage actually allocated +C IWORK(2) for the working arrays WORK(*) and IWORK(*), +C respectively. These quantities are compared with +C the actual amounts of storage needed for DWNNLS( ). +C Insufficient storage allocated for either WORK(*) +C or IWORK(*) is considered an error. This feature +C was included in DWNNLS( ) because miscalculating +C the storage formulas for WORK(*) and IWORK(*) +C might very well lead to subtle and hard-to-find +C execution errors. +C +C The length of WORK(*) must be at least +C +C LW = ME+MA+5*N +C This test will not be made if IWORK(1).LE.0. +C +C The length of IWORK(*) must be at least +C +C LIW = ME+MA+N +C This test will not be made if IWORK(2).LE.0. +C +C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION +C +C X(*) An array dimensioned at least N, which will +C contain the N components of the solution vector +C on output. +C +C RNORM The residual norm of the solution. The value of +C RNORM contains the residual vector length of the +C equality constraints and least squares equations. +C +C MODE The value of MODE indicates the success or failure +C of the subprogram. +C +C MODE = 0 Subprogram completed successfully. +C +C = 1 Max. number of iterations (equal to +C 3*(N-L)) exceeded. Nearly all problems +C should complete in fewer than this +C number of iterations. An approximate +C solution and its corresponding residual +C vector length are in X(*) and RNORM. +C +C = 2 Usage error occurred. The offending +C condition is noted with the error +C processing subprogram, XERMSG( ). +C +C User-designated +C Working arrays.. +C +C WORK(*) A double precision working array of length at least +C M + 5*N. +C +C IWORK(*) An integer-valued working array of length at least +C M+N. +C +C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for +C linear least squares problems with equality and +C nonnegativity constraints, Report SAND77-0552, Sandia +C Laboratories, June 1978. +C K. H. Haskell and R. J. Hanson, Selected algorithms for +C the linearly constrained least squares problem - a +C users guide, Report SAND78-1290, Sandia Laboratories, +C August 1979. +C K. H. Haskell and R. J. Hanson, An algorithm for +C linear least squares problems with equality and +C nonnegativity constraints, Mathematical Programming +C 21 (1981), pp. 98-118. +C R. J. Hanson and K. H. Haskell, Two algorithms for the +C linearly constrained least squares problem, ACM +C Transactions on Mathematical Software, September 1982. +C C. L. Lawson and R. J. Hanson, Solving Least Squares +C Problems, Prentice-Hall, Inc., 1974. +C***ROUTINES CALLED DWNLSM, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and revised. (WRB & RWC) +C 891006 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900510 Convert XERRWV calls to XERMSG calls, change Prologue +C comments to agree with WNNLS. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C 180613 Removed prints and replaced DP --> DOUBLE PRECISION. (THC) +C***END PROLOGUE DWNNLS + + INTEGER IWORK(*), L, L1, L2, L3, L4, L5, LIW, LW, MA, MDW, ME, + * MODE, N + DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) +C CHARACTER*8 XERN1 +C***FIRST EXECUTABLE STATEMENT DWNNLS + MODE = 0 + IF (MA+ME.LE.0 .OR. N.LE.0) RETURN +C + IF (IWORK(1).GT.0) THEN + LW = ME + MA + 5*N + IF (IWORK(1).LT.LW) THEN +C WRITE (XERN1, '(I8)') LW +C CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // +C * 'ALLOCATED FOR WORK(*), NEED LW = ' // XERN1, 2, 1) + MODE = 2 + RETURN + ENDIF + ENDIF +C + IF (IWORK(2).GT.0) THEN + LIW = ME + MA + N + IF (IWORK(2).LT.LIW) THEN +C WRITE (XERN1, '(I8)') LIW +C CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // +C * 'ALLOCATED FOR IWORK(*), NEED LIW = ' // XERN1, 2, 1) + MODE = 2 + RETURN + ENDIF + ENDIF +C + IF (MDW.LT.ME+MA) THEN +C CALL XERMSG ('SLATEC', 'DWNNLS', +C * 'THE VALUE MDW.LT.ME+MA IS AN ERROR', 1, 1) + MODE = 2 + RETURN + ENDIF +C + IF (L.LT.0 .OR. L.GT.N) THEN +C CALL XERMSG ('SLATEC', 'DWNNLS', +C * 'L.GE.0 .AND. L.LE.N IS REQUIRED', 2, 1) + MODE = 2 + RETURN + ENDIF +C +C THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS +C WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS +C REQUIRED BY THE MAIN SUBROUTINE DWNLSM( ). +C + L1 = N + 1 + L2 = L1 + N + L3 = L2 + ME + MA + L4 = L3 + N + L5 = L4 + N +C + CALL DWNLSM(W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, IWORK, + * IWORK(L1), WORK(1), WORK(L1), WORK(L2), WORK(L3), + * WORK(L4), WORK(L5)) + RETURN + END +*DECK DWNLSM + SUBROUTINE DWNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, + + IPIVOT, ITYPE, WD, H, SCALE, Z, TEMP, D) +C***BEGIN PROLOGUE DWNLSM +C***SUBSIDIARY +C***PURPOSE Subsidiary to DWNNLS +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (WNLSM-S, DWNLSM-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C This is a companion subprogram to DWNNLS. +C The documentation for DWNNLS has complete usage instructions. +C +C In addition to the parameters discussed in the prologue to +C subroutine DWNNLS, the following work arrays are used in +C subroutine DWNLSM (they are passed through the calling +C sequence from DWNNLS for purposes of variable dimensioning). +C Their contents will in general be of no interest to the user. +C +C Variables of type REAL are DOUBLE PRECISION. +C +C IPIVOT(*) +C An array of length N. Upon completion it contains the +C pivoting information for the cols of W(*,*). +C +C ITYPE(*) +C An array of length M which is used to keep track +C of the classification of the equations. ITYPE(I)=0 +C denotes equation I as an equality constraint. +C ITYPE(I)=1 denotes equation I as a least squares +C equation. +C +C WD(*) +C An array of length N. Upon completion it contains the +C dual solution vector. +C +C H(*) +C An array of length N. Upon completion it contains the +C pivot scalars of the Householder transformations performed +C in the case KRANK.LT.L. +C +C SCALE(*) +C An array of length M which is used by the subroutine +C to store the diagonal matrix of weights. +C These are used to apply the modified Givens +C transformations. +C +C Z(*),TEMP(*) +C Working arrays of length N. +C +C D(*) +C An array of length N that contains the +C column scaling for the matrix (E). +C (A) +C +C***SEE ALSO DWNNLS +C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, +C SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, +C DWNLIT, IDAMAX, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and revised. (WRB & RWC) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900328 Added TYPE section. (WRB) +C 900510 Fixed an error message. (RWC) +C 900604 DP version created from SP version. (RWC) +C 900911 Restriction on value of ALAMDA included. (WRB) +C***END PROLOGUE DWNLSM + + INTEGER IPIVOT(*), ITYPE(*), L, MA, MDW, MME, MODE, N + DOUBLE PRECISION D(*), H(*), PRGOPT(*), RNORM, SCALE(*), TEMP(*), + * W(MDW,*), WD(*), X(*), Z(*) +C + EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, SLATEC_DROTM, + * SLATEC_DROTMG, DSCAL, DSWAP, DWNLIT, IDAMAX, XERMSG + DOUBLE PRECISION D1MACH, DASUM, DNRM2 + INTEGER IDAMAX +C + DOUBLE PRECISION ALAMDA, ALPHA, ALSQ, AMAX, BLOWUP, BNORM, + * DOPE(3), DRELPR, EANORM, FAC, SM, SPARAM(5), T, TAU, WMAX, Z2, + * ZZ + INTEGER I, IDOPE(3), IMAX, ISOL, ITEMP, ITER, ITMAX, IWMAX, J, + * JCON, JP, KEY, KRANK, L1, LAST, LINK, M, ME, NEXT, NIV, NLINK, + * NOPT, NSOLN, NTIMES + LOGICAL DONE, FEASBL, FIRST, HITCON, POS +C + SAVE DRELPR, FIRST + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DWNLSM +C +C Initialize variables. +C DRELPR is the precision for the particular machine +C being used. This logic avoids resetting it every entry. +C + IF (FIRST) DRELPR = D1MACH(4) + FIRST = .FALSE. +C +C Set the nominal tolerance used in the code. +C + TAU = SQRT(DRELPR) +C + M = MA + MME + ME = MME + MODE = 2 +C +C To process option vector +C + FAC = 1.D-4 +C +C Set the nominal blow up factor used in the code. +C + BLOWUP = TAU +C +C The nominal column scaling used in the code is +C the identity scaling. +C + CALL DCOPY (N, 1.D0, 0, D, 1) +C +C Define bound for number of options to change. +C + NOPT = 1000 +C +C Define bound for positive value of LINK. +C + NLINK = 100000 + NTIMES = 0 + LAST = 1 + LINK = PRGOPT(1) + IF (LINK.LE.0 .OR. LINK.GT.NLINK) THEN +C CALL XERMSG ('SLATEC', 'DWNLSM', +C + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) + RETURN + ENDIF +C + 100 IF (LINK.GT.1) THEN + NTIMES = NTIMES + 1 + IF (NTIMES.GT.NOPT) THEN +C CALL XERMSG ('SLATEC', 'DWNLSM', +C + 'IN DWNNLS, THE LINKS IN THE OPTION VECTOR ARE CYCLING.', +C + 3, 1) + RETURN + ENDIF +C + KEY = PRGOPT(LAST+1) + IF (KEY.EQ.6 .AND. PRGOPT(LAST+2).NE.0.D0) THEN + DO 110 J = 1,N + T = DNRM2(M,W(1,J),1) + IF (T.NE.0.D0) T = 1.D0/T + D(J) = T + 110 CONTINUE + ENDIF +C + IF (KEY.EQ.7) CALL DCOPY (N, PRGOPT(LAST+2), 1, D, 1) + IF (KEY.EQ.8) TAU = MAX(DRELPR,PRGOPT(LAST+2)) + IF (KEY.EQ.9) BLOWUP = MAX(DRELPR,PRGOPT(LAST+2)) +C + NEXT = PRGOPT(LINK) + IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN +C CALL XERMSG ('SLATEC', 'DWNLSM', +C + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) + RETURN + ENDIF +C + LAST = LINK + LINK = NEXT + GO TO 100 + ENDIF +C + DO 120 J = 1,N + CALL DSCAL (M, D(J), W(1,J), 1) + 120 CONTINUE +C +C Process option vector +C + DONE = .FALSE. + ITER = 0 + ITMAX = 3*(N-L) + MODE = 0 + NSOLN = L + L1 = MIN(M,L) +C +C Compute scale factor to apply to equality constraint equations. +C + DO 130 J = 1,N + WD(J) = DASUM(M,W(1,J),1) + 130 CONTINUE +C + IMAX = IDAMAX(N,WD,1) + EANORM = WD(IMAX) + BNORM = DASUM(M,W(1,N+1),1) + ALAMDA = EANORM/(DRELPR*FAC) +C +C On machines, such as the VAXes using D floating, with a very +C limited exponent range for double precision values, the previously +C computed value of ALAMDA may cause an overflow condition. +C Therefore, this code further limits the value of ALAMDA. +C + ALAMDA = MIN(ALAMDA,SQRT(D1MACH(2))) +C +C Define scaling diagonal matrix for modified Givens usage and +C classify equation types. +C + ALSQ = ALAMDA**2 + DO 140 I = 1,M +C +C When equation I is heavily weighted ITYPE(I)=0, +C else ITYPE(I)=1. +C + IF (I.LE.ME) THEN + T = ALSQ + ITEMP = 0 + ELSE + T = 1.D0 + ITEMP = 1 + ENDIF + SCALE(I) = T + ITYPE(I) = ITEMP + 140 CONTINUE +C +C Set the solution vector X(*) to zero and the column interchange +C matrix to the identity. +C + CALL DCOPY (N, 0.D0, 0, X, 1) + DO 150 I = 1,N + IPIVOT(I) = I + 150 CONTINUE +C +C Perform initial triangularization in the submatrix +C corresponding to the unconstrained variables. +C Set first L components of dual vector to zero because +C these correspond to the unconstrained variables. +C + CALL DCOPY (L, 0.D0, 0, WD, 1) +C +C The arrays IDOPE(*) and DOPE(*) are used to pass +C information to DWNLIT(). This was done to avoid +C a long calling sequence or the use of COMMON. +C + IDOPE(1) = ME + IDOPE(2) = NSOLN + IDOPE(3) = L1 +C + DOPE(1) = ALSQ + DOPE(2) = EANORM + DOPE(3) = TAU + CALL DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM, + + IDOPE, DOPE, DONE) + ME = IDOPE(1) + KRANK = IDOPE(2) + NIV = IDOPE(3) +C +C Perform WNNLS algorithm using the following steps. +C +C Until(DONE) +C compute search direction and feasible point +C when (HITCON) add constraints +C else perform multiplier test and drop a constraint +C fin +C Compute-Final-Solution +C +C To compute search direction and feasible point, +C solve the triangular system of currently non-active +C variables and store the solution in Z(*). +C +C To solve system +C Copy right hand side into TEMP vector to use overwriting method. +C + 160 IF (DONE) GO TO 330 + ISOL = L + 1 + IF (NSOLN.GE.ISOL) THEN + CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) + DO 170 J = NSOLN,ISOL,-1 + IF (J.GT.KRANK) THEN + I = NIV - NSOLN + J + ELSE + I = J + ENDIF +C + IF (J.GT.KRANK .AND. J.LE.L) THEN + Z(J) = 0.D0 + ELSE + Z(J) = TEMP(I)/W(I,J) + CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) + ENDIF + 170 CONTINUE + ENDIF +C +C Increment iteration counter and check against maximum number +C of iterations. +C + ITER = ITER + 1 + IF (ITER.GT.ITMAX) THEN + MODE = 1 + DONE = .TRUE. + ENDIF +C +C Check to see if any constraints have become active. +C If so, calculate an interpolation factor so that all +C active constraints are removed from the basis. +C + ALPHA = 2.D0 + HITCON = .FALSE. + DO 180 J = L+1,NSOLN + ZZ = Z(J) + IF (ZZ.LE.0.D0) THEN + T = X(J)/(X(J)-ZZ) + IF (T.LT.ALPHA) THEN + ALPHA = T + JCON = J + ENDIF + HITCON = .TRUE. + ENDIF + 180 CONTINUE +C +C Compute search direction and feasible point +C + IF (HITCON) THEN +C +C To add constraints, use computed ALPHA to interpolate between +C last feasible solution X(*) and current unconstrained (and +C infeasible) solution Z(*). +C + DO 190 J = L+1,NSOLN + X(J) = X(J) + ALPHA*(Z(J)-X(J)) + 190 CONTINUE + FEASBL = .FALSE. +C +C Remove column JCON and shift columns JCON+1 through N to the +C left. Swap column JCON into the N th position. This achieves +C upper Hessenberg form for the nonactive constraints and +C leaves an upper Hessenberg matrix to retriangularize. +C + 200 DO 210 I = 1,M + T = W(I,JCON) + CALL DCOPY (N-JCON, W(I, JCON+1), MDW, W(I, JCON), MDW) + W(I,N) = T + 210 CONTINUE +C +C Update permuted index vector to reflect this shift and swap. +C + ITEMP = IPIVOT(JCON) + DO 220 I = JCON,N - 1 + IPIVOT(I) = IPIVOT(I+1) + 220 CONTINUE + IPIVOT(N) = ITEMP +C +C Similarly permute X(*) vector. +C + CALL DCOPY (N-JCON, X(JCON+1), 1, X(JCON), 1) + X(N) = 0.D0 + NSOLN = NSOLN - 1 + NIV = NIV - 1 +C +C Retriangularize upper Hessenberg matrix after adding +C constraints. +C + I = KRANK + JCON - L + DO 230 J = JCON,NSOLN + IF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.0) THEN +C +C Zero IP1 to I in column J +C + IF (W(I+1,J).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), + + W(I+1,J), SPARAM) + W(I+1,J) = 0.D0 + CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), + + MDW, SPARAM) + ENDIF + ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.1) THEN +C +C Zero IP1 to I in column J +C + IF (W(I+1,J).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), + + W(I+1,J), SPARAM) + W(I+1,J) = 0.D0 + CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), + + MDW, SPARAM) + ENDIF + ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.0) THEN + CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) + CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) + ITEMP = ITYPE(I+1) + ITYPE(I+1) = ITYPE(I) + ITYPE(I) = ITEMP +C +C Swapped row was formerly a pivot element, so it will +C be large enough to perform elimination. +C Zero IP1 to I in column J. +C + IF (W(I+1,J).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), + + W(I+1,J), SPARAM) + W(I+1,J) = 0.D0 + CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), + + MDW, SPARAM) + ENDIF + ELSEIF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.1) THEN + IF (SCALE(I)*W(I,J)**2/ALSQ.GT.(TAU*EANORM)**2) THEN +C +C Zero IP1 to I in column J +C + IF (W(I+1,J).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), + + W(I+1,J), SPARAM) + W(I+1,J) = 0.D0 + CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, + + W(I+1,J+1), MDW, SPARAM) + ENDIF + ELSE + CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) + CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) + ITEMP = ITYPE(I+1) + ITYPE(I+1) = ITYPE(I) + ITYPE(I) = ITEMP + W(I+1,J) = 0.D0 + ENDIF + ENDIF + I = I + 1 + 230 CONTINUE +C +C See if the remaining coefficients in the solution set are +C feasible. They should be because of the way ALPHA was +C determined. If any are infeasible, it is due to roundoff +C error. Any that are non-positive will be set to zero and +C removed from the solution set. +C + DO 240 JCON = L+1,NSOLN + IF (X(JCON).LE.0.D0) GO TO 250 + 240 CONTINUE + FEASBL = .TRUE. + 250 IF (.NOT.FEASBL) GO TO 200 + ELSE +C +C To perform multiplier test and drop a constraint. +C + CALL DCOPY (NSOLN, Z, 1, X, 1) + IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) +C +C Reclassify least squares equations as equalities as necessary. +C + I = NIV + 1 + 260 IF (I.LE.ME) THEN + IF (ITYPE(I).EQ.0) THEN + I = I + 1 + ELSE + CALL DSWAP (N+1, W(I,1), MDW, W(ME,1), MDW) + CALL DSWAP (1, SCALE(I), 1, SCALE(ME), 1) + ITEMP = ITYPE(I) + ITYPE(I) = ITYPE(ME) + ITYPE(ME) = ITEMP + ME = ME - 1 + ENDIF + GO TO 260 + ENDIF +C +C Form inner product vector WD(*) of dual coefficients. +C + DO 280 J = NSOLN+1,N + SM = 0.D0 + DO 270 I = NSOLN+1,M + SM = SM + SCALE(I)*W(I,J)*W(I,N+1) + 270 CONTINUE + WD(J) = SM + 280 CONTINUE +C +C Find J such that WD(J)=WMAX is maximum. This determines +C that the incoming column J will reduce the residual vector +C and be positive. +C + 290 WMAX = 0.D0 + IWMAX = NSOLN + 1 + DO 300 J = NSOLN+1,N + IF (WD(J).GT.WMAX) THEN + WMAX = WD(J) + IWMAX = J + ENDIF + 300 CONTINUE + IF (WMAX.LE.0.D0) GO TO 330 +C +C Set dual coefficients to zero for incoming column. +C + WD(IWMAX) = 0.D0 +C +C WMAX .GT. 0.D0, so okay to move column IWMAX to solution set. +C Perform transformation to retriangularize, and test for near +C linear dependence. +C +C Swap column IWMAX into NSOLN-th position to maintain upper +C Hessenberg form of adjacent columns, and add new column to +C triangular decomposition. +C + NSOLN = NSOLN + 1 + NIV = NIV + 1 + IF (NSOLN.NE.IWMAX) THEN + CALL DSWAP (M, W(1,NSOLN), 1, W(1,IWMAX), 1) + WD(IWMAX) = WD(NSOLN) + WD(NSOLN) = 0.D0 + ITEMP = IPIVOT(NSOLN) + IPIVOT(NSOLN) = IPIVOT(IWMAX) + IPIVOT(IWMAX) = ITEMP + ENDIF +C +C Reduce column NSOLN so that the matrix of nonactive constraints +C variables is triangular. +C + DO 320 J = M,NIV+1,-1 + JP = J - 1 +C +C When operating near the ME line, test to see if the pivot +C element is near zero. If so, use the largest element above +C it as the pivot. This is to maintain the sharp interface +C between weighted and non-weighted rows in all cases. +C + IF (J.EQ.ME+1) THEN + IMAX = ME + AMAX = SCALE(ME)*W(ME,NSOLN)**2 + DO 310 JP = J - 1,NIV,-1 + T = SCALE(JP)*W(JP,NSOLN)**2 + IF (T.GT.AMAX) THEN + IMAX = JP + AMAX = T + ENDIF + 310 CONTINUE + JP = IMAX + ENDIF +C + IF (W(J,NSOLN).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(JP), SCALE(J), W(JP,NSOLN), + + W(J,NSOLN), SPARAM) + W(J,NSOLN) = 0.D0 + CALL SLATEC_DROTM (N+1-NSOLN, W(JP,NSOLN+1), MDW, + + W(J,NSOLN+1), MDW, SPARAM) + ENDIF + 320 CONTINUE +C +C Solve for Z(NSOLN)=proposed new value for X(NSOLN). Test if +C this is nonpositive or too large. If this was true or if the +C pivot term was zero, reject the column as dependent. +C + IF (W(NIV,NSOLN).NE.0.D0) THEN + ISOL = NIV + Z2 = W(ISOL,N+1)/W(ISOL,NSOLN) + Z(NSOLN) = Z2 + POS = Z2 .GT. 0.D0 + IF (Z2*EANORM.GE.BNORM .AND. POS) THEN + POS = .NOT. (BLOWUP*Z2*EANORM.GE.BNORM) + ENDIF +C +C Try to add row ME+1 as an additional equality constraint. +C Check size of proposed new solution component. +C Reject it if it is too large. +C + ELSEIF (NIV.LE.ME .AND. W(ME+1,NSOLN).NE.0.D0) THEN + ISOL = ME + 1 + IF (POS) THEN +C +C Swap rows ME+1 and NIV, and scale factors for these rows. +C + CALL DSWAP (N+1, W(ME+1,1), MDW, W(NIV,1), MDW) + CALL DSWAP (1, SCALE(ME+1), 1, SCALE(NIV), 1) + ITEMP = ITYPE(ME+1) + ITYPE(ME+1) = ITYPE(NIV) + ITYPE(NIV) = ITEMP + ME = ME + 1 + ENDIF + ELSE + POS = .FALSE. + ENDIF +C + IF (.NOT.POS) THEN + NSOLN = NSOLN - 1 + NIV = NIV - 1 + ENDIF + IF (.NOT.(POS.OR.DONE)) GO TO 290 + ENDIF + GO TO 160 +C +C Else perform multiplier test and drop a constraint. To compute +C final solution. Solve system, store results in X(*). +C +C Copy right hand side into TEMP vector to use overwriting method. +C + 330 ISOL = 1 + IF (NSOLN.GE.ISOL) THEN + CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) + DO 340 J = NSOLN,ISOL,-1 + IF (J.GT.KRANK) THEN + I = NIV - NSOLN + J + ELSE + I = J + ENDIF +C + IF (J.GT.KRANK .AND. J.LE.L) THEN + Z(J) = 0.D0 + ELSE + Z(J) = TEMP(I)/W(I,J) + CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) + ENDIF + 340 CONTINUE + ENDIF +C +C Solve system. +C + CALL DCOPY (NSOLN, Z, 1, X, 1) +C +C Apply Householder transformations to X(*) if KRANK.LT.L +C + IF (KRANK.LT.L) THEN + DO 350 I = 1,KRANK + CALL DH12 (2, I, KRANK+1, L, W(I,1), MDW, H(I), X, 1, 1, 1) + 350 CONTINUE + ENDIF +C +C Fill in trailing zeroes for constrained variables not in solution. +C + IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) +C +C Permute solution vector to natural order. +C + DO 380 I = 1,N + J = I + 360 IF (IPIVOT(J).EQ.I) GO TO 370 + J = J + 1 + GO TO 360 +C + 370 IPIVOT(J) = IPIVOT(I) + IPIVOT(I) = J + CALL DSWAP (1, X(J), 1, X(I), 1) + 380 CONTINUE +C +C Rescale the solution using the column scaling. +C + DO 390 J = 1,N + X(J) = X(J)*D(J) + 390 CONTINUE +C + DO 400 I = NSOLN+1,M + T = W(I,N+1) + IF (I.LE.ME) T = T/ALAMDA + T = (SCALE(I)*T)*T + RNORM = RNORM + T + 400 CONTINUE +C + RNORM = SQRT(RNORM) + RETURN + END +*DECK DROTM + SUBROUTINE SLATEC_DROTM (N, DX, INCX, DY, INCY, DPARAM) +C***BEGIN PROLOGUE SLATEC_DROTM +C***PURPOSE Apply a modified Givens transformation. +C***LIBRARY SLATEC (BLAS) +C***CATEGORY D1A8 +C***TYPE DOUBLE PRECISION (SROTM-S, DROTM-D) +C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***DESCRIPTION +C +C B L A S Subprogram +C Description of Parameters +C +C --Input-- +C N number of elements in input vector(s) +C DX double precision vector with N elements +C INCX storage spacing between elements of DX +C DY double precision vector with N elements +C INCY storage spacing between elements of DY +C DPARAM 5-element D.P. vector. DPARAM(1) is DFLAG described below. +C Locations 2-5 of SPARAM contain elements of the +C transformation matrix H described below. +C +C --Output-- +C DX rotated vector (unchanged if N .LE. 0) +C DY rotated vector (unchanged if N .LE. 0) +C +C Apply the modified Givens transformation, H, to the 2 by N matrix +C (DX**T) +C (DY**T) , where **T indicates transpose. The elements of DX are +C in DX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else +C LX = 1+(1-N)*INCX, and similarly for DY using LY and INCY. +C +C With DPARAM(1)=DFLAG, H has one of the following forms: +C +C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 +C +C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) +C H=( ) ( ) ( ) ( ) +C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). +C +C See SLATEC_DROTMG for a description of data storage in DPARAM. +C +C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +C Krogh, Basic linear algebra subprograms for Fortran +C usage, Algorithm No. 539, Transactions on Mathematical +C Software 5, 3 (September 1979), pp. 308-323. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 791001 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920310 Corrected definition of LX in DESCRIPTION. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 180613 Renamed SLATEC_DROTM to avoid BLAS naming conflict. (THC) +C***END PROLOGUE SLATEC_DROTM + + DOUBLE PRECISION DFLAG, DH12, DH22, DX, TWO, Z, DH11, DH21, + 1 DPARAM, DY, W, ZERO + DIMENSION DX(*), DY(*), DPARAM(5) + SAVE ZERO, TWO + DATA ZERO, TWO /0.0D0, 2.0D0/ +C***FIRST EXECUTABLE STATEMENT SLATEC_DROTM + DFLAG=DPARAM(1) + IF (N.LE.0 .OR. (DFLAG+TWO.EQ.ZERO)) GO TO 140 + IF (.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 +C + NSTEPS=N*INCX +C IF (DFLAG) 50, 10, 30 +C Replaced obsolete code above with an IF-block (THC). + IF (DFLAG < 0) THEN + GO TO 50 + ELSE IF (DFLAG == 0) THEN + GO TO 10 + ELSE IF (DFLAG > 0) THEN + GO TO 30 + END IF + 10 CONTINUE + DH12=DPARAM(4) + DH21=DPARAM(3) + DO 20 I = 1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=W+Z*DH12 + DY(I)=W*DH21+Z + 20 CONTINUE + GO TO 140 + 30 CONTINUE + DH11=DPARAM(2) + DH22=DPARAM(5) + DO 40 I = 1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=W*DH11+Z + DY(I)=-W+DH22*Z + 40 CONTINUE + GO TO 140 + 50 CONTINUE + DH11=DPARAM(2) + DH12=DPARAM(4) + DH21=DPARAM(3) + DH22=DPARAM(5) + DO 60 I = 1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=W*DH11+Z*DH12 + DY(I)=W*DH21+Z*DH22 + 60 CONTINUE + GO TO 140 + 70 CONTINUE + KX=1 + KY=1 + IF (INCX .LT. 0) KX = 1+(1-N)*INCX + IF (INCY .LT. 0) KY = 1+(1-N)*INCY +C +C IF (DFLAG) 120,80,100 +C Replaced obsolete code above with an IF-block (THC). + IF (DFLAG < 0) THEN + GO TO 120 + ELSE IF (DFLAG == 0) THEN + GO TO 80 + ELSE IF (DFLAG > 0) THEN + GO TO 100 + END IF + 80 CONTINUE + DH12=DPARAM(4) + DH21=DPARAM(3) + DO 90 I = 1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=W+Z*DH12 + DY(KY)=W*DH21+Z + KX=KX+INCX + KY=KY+INCY + 90 CONTINUE + GO TO 140 + 100 CONTINUE + DH11=DPARAM(2) + DH22=DPARAM(5) + DO 110 I = 1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=W*DH11+Z + DY(KY)=-W+DH22*Z + KX=KX+INCX + KY=KY+INCY + 110 CONTINUE + GO TO 140 + 120 CONTINUE + DH11=DPARAM(2) + DH12=DPARAM(4) + DH21=DPARAM(3) + DH22=DPARAM(5) + DO 130 I = 1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=W*DH11+Z*DH12 + DY(KY)=W*DH21+Z*DH22 + KX=KX+INCX + KY=KY+INCY + 130 CONTINUE + 140 CONTINUE + RETURN + END +*DECK SLATEC_DROTMG + SUBROUTINE SLATEC_DROTMG (DD1, DD2, DX1, DY1, DPARAM) +C***BEGIN PROLOGUE SLATEC_DROTMG +C***PURPOSE Construct a modified Givens transformation. +C***LIBRARY SLATEC (BLAS) +C***CATEGORY D1B10 +C***TYPE DOUBLE PRECISION (SROTMG-S, DROTMG-D) +C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***DESCRIPTION +C +C B L A S Subprogram +C Description of Parameters +C +C --Input-- +C DD1 double precision scalar +C DD2 double precision scalar +C DX1 double precision scalar +C DX2 double precision scalar +C DPARAM D.P. 5-vector. DPARAM(1)=DFLAG defined below. +C Locations 2-5 contain the rotation matrix. +C +C --Output-- +C DD1 changed to represent the effect of the transformation +C DD2 changed to represent the effect of the transformation +C DX1 changed to represent the effect of the transformation +C DX2 unchanged +C +C Construct the modified Givens transformation matrix H which zeros +C the second component of the 2-vector (SQRT(DD1)*DX1,SQRT(DD2)* +C DY2)**T. +C With DPARAM(1)=DFLAG, H has one of the following forms: +C +C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 +C +C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) +C H=( ) ( ) ( ) ( ) +C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). +C +C Locations 2-5 of DPARAM contain DH11, DH21, DH12, and DH22, +C respectively. (Values of 1.D0, -1.D0, or 0.D0 implied by the +C value of DPARAM(1) are not stored in DPARAM.) +C +C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +C Krogh, Basic linear algebra subprograms for Fortran +C usage, Algorithm No. 539, Transactions on Mathematical +C Software 5, 3 (September 1979), pp. 308-323. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 780301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920316 Prologue corrected. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 180613 Renamed SLATEC_DROTMG to avoid BLAS naming conflict. (THC) +C***END PROLOGUE SLATEC_DROTMG + + DOUBLE PRECISION GAM, ONE, RGAMSQ, DD1, DD2, DH11, DH12, DH21, + 1 DH22, DPARAM, DP1, DP2, DQ1, DQ2, DU, DY1, ZERO, + 2 GAMSQ, DFLAG, DTEMP, DX1, TWO + DIMENSION DPARAM(5) + SAVE ZERO, ONE, TWO, GAM, GAMSQ, RGAMSQ + DATA ZERO, ONE, TWO /0.0D0, 1.0D0, 2.0D0/ + DATA GAM, GAMSQ, RGAMSQ /4096.0D0, 16777216.D0, 5.9604645D-8/ +C***FIRST EXECUTABLE STATEMENT SLATEC_DROTMG + IF (.NOT. DD1 .LT. ZERO) GO TO 10 +C GO ZERO-H-D-AND-DX1.. + GO TO 60 + 10 CONTINUE +C CASE-DD1-NONNEGATIVE + DP2=DD2*DY1 + IF (.NOT. DP2 .EQ. ZERO) GO TO 20 + DFLAG=-TWO + GO TO 260 +C REGULAR-CASE.. + 20 CONTINUE + DP1=DD1*DX1 + DQ2=DP2*DY1 + DQ1=DP1*DX1 +C + IF (.NOT. ABS(DQ1) .GT. ABS(DQ2)) GO TO 40 + DH21=-DY1/DX1 + DH12=DP2/DP1 +C + DU=ONE-DH12*DH21 +C + IF (.NOT. DU .LE. ZERO) GO TO 30 +C GO ZERO-H-D-AND-DX1.. + GO TO 60 + 30 CONTINUE + DFLAG=ZERO + DD1=DD1/DU + DD2=DD2/DU + DX1=DX1*DU +C GO SCALE-CHECK.. + GO TO 100 + 40 CONTINUE + IF (.NOT. DQ2 .LT. ZERO) GO TO 50 +C GO ZERO-H-D-AND-DX1.. + GO TO 60 + 50 CONTINUE + DFLAG=ONE + DH11=DP1/DP2 + DH22=DX1/DY1 + DU=ONE+DH11*DH22 + DTEMP=DD2/DU + DD2=DD1/DU + DD1=DTEMP + DX1=DY1*DU +C GO SCALE-CHECK + GO TO 100 +C PROCEDURE..ZERO-H-D-AND-DX1.. + 60 CONTINUE + DFLAG=-ONE + DH11=ZERO + DH12=ZERO + DH21=ZERO + DH22=ZERO +C + DD1=ZERO + DD2=ZERO + DX1=ZERO +C RETURN.. + GO TO 220 +C PROCEDURE..FIX-H.. + 70 CONTINUE + IF (.NOT. DFLAG .GE. ZERO) GO TO 90 +C + IF (.NOT. DFLAG .EQ. ZERO) GO TO 80 + DH11=ONE + DH22=ONE + DFLAG=-ONE + GO TO 90 + 80 CONTINUE + DH21=-ONE + DH12=ONE + DFLAG=-ONE + 90 CONTINUE +C GO TO IGO,(120,150,180,210) +C Replaced the above obsolete code with modern alternative (THC). + SELECT CASE(IGO) + CASE(120) + GO TO 120 + CASE(150) + GO TO 150 + CASE(180) + GO TO 180 + CASE(210) + GO TO 210 + END SELECT +C PROCEDURE..SCALE-CHECK + 100 CONTINUE + 110 CONTINUE + IF (.NOT. DD1 .LE. RGAMSQ) GO TO 130 + IF (DD1 .EQ. ZERO) GO TO 160 + IGO = 120 +C FIX-H.. + GO TO 70 + 120 CONTINUE + DD1=DD1*GAM**2 + DX1=DX1/GAM + DH11=DH11/GAM + DH12=DH12/GAM + GO TO 110 + 130 CONTINUE + 140 CONTINUE + IF (.NOT. DD1 .GE. GAMSQ) GO TO 160 + IGO = 150 +C FIX-H.. + GO TO 70 + 150 CONTINUE + DD1=DD1/GAM**2 + DX1=DX1*GAM + DH11=DH11*GAM + DH12=DH12*GAM + GO TO 140 + 160 CONTINUE + 170 CONTINUE + IF (.NOT. ABS(DD2) .LE. RGAMSQ) GO TO 190 + IF (DD2 .EQ. ZERO) GO TO 220 + IGO = 180 +C FIX-H.. + GO TO 70 + 180 CONTINUE + DD2=DD2*GAM**2 + DH21=DH21/GAM + DH22=DH22/GAM + GO TO 170 + 190 CONTINUE + 200 CONTINUE + IF (.NOT. ABS(DD2) .GE. GAMSQ) GO TO 220 + IGO = 210 +C FIX-H.. + GO TO 70 + 210 CONTINUE + DD2=DD2/GAM**2 + DH21=DH21*GAM + DH22=DH22*GAM + GO TO 200 + 220 CONTINUE +C IF (DFLAG) 250,230,240 +C Replaced obsolete code above with an IF-block (THC). + IF (DFLAG < 0) THEN + GO TO 250 + ELSE IF (DFLAG == 0) THEN + GO TO 230 + ELSE IF (DFLAG > 0) THEN + GO TO 240 + END IF + + 230 CONTINUE + DPARAM(3)=DH21 + DPARAM(4)=DH12 + GO TO 260 + 240 CONTINUE + DPARAM(2)=DH11 + DPARAM(5)=DH22 + GO TO 260 + 250 CONTINUE + DPARAM(2)=DH11 + DPARAM(3)=DH21 + DPARAM(4)=DH12 + DPARAM(5)=DH22 + 260 CONTINUE + DPARAM(1)=DFLAG + RETURN + END +*DECK DWNLIT + SUBROUTINE DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, + + RNORM, IDOPE, DOPE, DONE) +C***BEGIN PROLOGUE DWNLIT +C***SUBSIDIARY +C***PURPOSE Subsidiary to DWNNLS +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (WNLIT-S, DWNLIT-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C This is a companion subprogram to DWNNLS( ). +C The documentation for DWNNLS( ) has complete usage instructions. +C +C Note The M by (N+1) matrix W( , ) contains the rt. hand side +C B as the (N+1)st col. +C +C Triangularize L1 by L1 subsystem, where L1=MIN(M,L), with +C col interchanges. +C +C***SEE ALSO DWNNLS +C***ROUTINES CALLED DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, +C DSWAP, DWNLT1, DWNLT2, DWNLT3, IDAMAX +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and revised. (WRB & RWC) +C 890620 Revised to make WNLT1, WNLT2, and WNLT3 subroutines. (RWC) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900604 DP version created from SP version. . (RWC) +C***END PROLOGUE DWNLIT + + INTEGER IDOPE(*), IPIVOT(*), ITYPE(*), L, M, MDW, N + DOUBLE PRECISION DOPE(*), H(*), RNORM, SCALE(*), W(MDW,*) + LOGICAL DONE +C + EXTERNAL DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, + * DWNLT1, DWNLT2, DWNLT3, IDAMAX + INTEGER IDAMAX + LOGICAL DWNLT2 +C + DOUBLE PRECISION ALSQ, AMAX, EANORM, FACTOR, HBAR, RN, SPARAM(5), + * T, TAU + INTEGER I, I1, IMAX, IR, J, J1, JJ, JP, KRANK, L1, LB, LEND, ME, + * MEND, NIV, NSOLN + LOGICAL INDEP, RECALC +C +C***FIRST EXECUTABLE STATEMENT DWNLIT + ME = IDOPE(1) + NSOLN = IDOPE(2) + L1 = IDOPE(3) +C + ALSQ = DOPE(1) + EANORM = DOPE(2) + TAU = DOPE(3) +C + LB = MIN(M-1,L) + RECALC = .TRUE. + RNORM = 0.D0 + KRANK = 0 +C +C We set FACTOR=1.0 so that the heavy weight ALAMDA will be +C included in the test for column independence. +C + FACTOR = 1.D0 + LEND = L + DO 180 I=1,LB +C +C Set IR to point to the I-th row. +C + IR = I + MEND = M + CALL DWNLT1 (I, LEND, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, + + W) +C +C Update column SS and find pivot column. +C + CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) +C +C Perform column interchange. +C Test independence of incoming column. +C + 130 IF (DWNLT2(ME, MEND, IR, FACTOR, TAU, SCALE, W(1,I))) THEN +C +C Eliminate I-th column below diagonal using modified Givens +C transformations applied to (A B). +C +C When operating near the ME line, use the largest element +C above it as the pivot. +C + DO 160 J=M,I+1,-1 + JP = J-1 + IF (J.EQ.ME+1) THEN + IMAX = ME + AMAX = SCALE(ME)*W(ME,I)**2 + DO 150 JP=J-1,I,-1 + T = SCALE(JP)*W(JP,I)**2 + IF (T.GT.AMAX) THEN + IMAX = JP + AMAX = T + ENDIF + 150 CONTINUE + JP = IMAX + ENDIF +C + IF (W(J,I).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(JP), SCALE(J), W(JP,I), + + W(J,I), SPARAM) + W(J,I) = 0.D0 + CALL SLATEC_DROTM (N+1-I, W(JP,I+1), MDW, W(J,I+1), + + MDW, SPARAM) + ENDIF + 160 CONTINUE + ELSE IF (LEND.GT.I) THEN +C +C Column I is dependent. Swap with column LEND. +C Perform column interchange, +C and find column in remaining set with largest SS. +C + CALL DWNLT3 (I, LEND, M, MDW, IPIVOT, H, W) + LEND = LEND - 1 + IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 + HBAR = H(IMAX) + GO TO 130 + ELSE + KRANK = I - 1 + GO TO 190 + ENDIF + 180 CONTINUE + KRANK = L1 +C + 190 IF (KRANK.LT.ME) THEN + FACTOR = ALSQ + DO 200 I=KRANK+1,ME + CALL DCOPY (L, 0.D0, 0, W(I,1), MDW) + 200 CONTINUE +C +C Determine the rank of the remaining equality constraint +C equations by eliminating within the block of constrained +C variables. Remove any redundant constraints. +C + RECALC = .TRUE. + LB = MIN(L+ME-KRANK, N) + DO 270 I=L+1,LB + IR = KRANK + I - L + LEND = N + MEND = ME + CALL DWNLT1 (I, LEND, ME, IR, MDW, RECALC, IMAX, HBAR, H, + + SCALE, W) +C +C Update col ss and find pivot col +C + CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) +C +C Perform column interchange +C Eliminate elements in the I-th col. +C + DO 240 J=ME,IR+1,-1 + IF (W(J,I).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), + + W(J,I), SPARAM) + W(J,I) = 0.D0 + CALL SLATEC_DROTM (N+1-I, W(J-1,I+1), MDW,W(J,I+1), + + MDW, SPARAM) + ENDIF + 240 CONTINUE +C +C I=column being eliminated. +C Test independence of incoming column. +C Remove any redundant or dependent equality constraints. +C + IF (.NOT.DWNLT2(ME, MEND, IR, FACTOR,TAU,SCALE,W(1,I))) THEN + JJ = IR + DO 260 IR=JJ,ME + CALL DCOPY (N, 0.D0, 0, W(IR,1), MDW) + RNORM = RNORM + (SCALE(IR)*W(IR,N+1)/ALSQ)*W(IR,N+1) + W(IR,N+1) = 0.D0 + SCALE(IR) = 1.D0 +C +C Reclassify the zeroed row as a least squares equation. +C + ITYPE(IR) = 1 + 260 CONTINUE +C +C Reduce ME to reflect any discovered dependent equality +C constraints. +C + ME = JJ - 1 + GO TO 280 + ENDIF + 270 CONTINUE + ENDIF +C +C Try to determine the variables KRANK+1 through L1 from the +C least squares equations. Continue the triangularization with +C pivot element W(ME+1,I). +C + 280 IF (KRANK.LT.L1) THEN + RECALC = .TRUE. +C +C Set FACTOR=ALSQ to remove effect of heavy weight from +C test for column independence. +C + FACTOR = ALSQ + DO 350 I=KRANK+1,L1 +C +C Set IR to point to the ME+1-st row. +C + IR = ME+1 + LEND = L + MEND = M + CALL DWNLT1 (I, L, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, + + W) +C +C Update column SS and find pivot column. +C + CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) +C +C Perform column interchange. +C Eliminate I-th column below the IR-th element. +C + DO 320 J=M,IR+1,-1 + IF (W(J,I).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), + + W(J,I), SPARAM) + W(J,I) = 0.D0 + CALL SLATEC_DROTM (N+1-I, W(J-1,I+1), MDW, W(J,I+1), + + MDW, SPARAM) + ENDIF + 320 CONTINUE +C +C Test if new pivot element is near zero. +C If so, the column is dependent. +C Then check row norm test to be classified as independent. +C + T = SCALE(IR)*W(IR,I)**2 + INDEP = T .GT. (TAU*EANORM)**2 + IF (INDEP) THEN + RN = 0.D0 + DO 340 I1=IR,M + DO 330 J1=I+1,N + RN = MAX(RN, SCALE(I1)*W(I1,J1)**2) + 330 CONTINUE + 340 CONTINUE + INDEP = T .GT. RN*TAU**2 + ENDIF +C +C If independent, swap the IR-th and KRANK+1-th rows to +C maintain the triangular form. Update the rank indicator +C KRANK and the equality constraint pointer ME. +C + IF (.NOT.INDEP) GO TO 360 + CALL DSWAP(N+1, W(KRANK+1,1), MDW, W(IR,1), MDW) + CALL DSWAP(1, SCALE(KRANK+1), 1, SCALE(IR), 1) +C +C Reclassify the least square equation as an equality +C constraint and rescale it. +C + ITYPE(IR) = 0 + T = SQRT(SCALE(KRANK+1)) + CALL DSCAL(N+1, T, W(KRANK+1,1), MDW) + SCALE(KRANK+1) = ALSQ + ME = ME+1 + KRANK = KRANK+1 + 350 CONTINUE + ENDIF +C +C If pseudorank is less than L, apply Householder transformation. +C from right. +C + 360 IF (KRANK.LT.L) THEN + DO 370 J=KRANK,1,-1 + CALL DH12 (1, J, KRANK+1, L, W(J,1), MDW, H(J), W, MDW, 1, + + J-1) + 370 CONTINUE + ENDIF +C + NIV = KRANK + NSOLN - L + IF (L.EQ.N) DONE = .TRUE. +C +C End of initial triangularization. +C + IDOPE(1) = ME + IDOPE(2) = KRANK + IDOPE(3) = NIV + RETURN + END +*DECK DWNLT1 + SUBROUTINE DWNLT1 (I, LEND, MEND, IR, MDW, RECALC, IMAX, HBAR, H, + + SCALE, W) +C***BEGIN PROLOGUE DWNLT1 +C***SUBSIDIARY +C***PURPOSE Subsidiary to WNLIT +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (WNLT1-S, DWNLT1-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C To update the column Sum Of Squares and find the pivot column. +C The column Sum of Squares Vector will be updated at each step. +C When numerically necessary, these values will be recomputed. +C +C***SEE ALSO DWNLIT +C***ROUTINES CALLED IDAMAX +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) +C 900604 DP version created from SP version. (RWC) +C***END PROLOGUE DWNLT1 + + INTEGER I, IMAX, IR, LEND, MDW, MEND + DOUBLE PRECISION H(*), HBAR, SCALE(*), W(MDW,*) + LOGICAL RECALC +C + EXTERNAL IDAMAX + INTEGER IDAMAX +C + INTEGER J, K +C +C***FIRST EXECUTABLE STATEMENT DWNLT1 + IF (IR.NE.1 .AND. (.NOT.RECALC)) THEN +C +C Update column SS=sum of squares. +C + DO 10 J=I,LEND + H(J) = H(J) - SCALE(IR-1)*W(IR-1,J)**2 + 10 CONTINUE +C +C Test for numerical accuracy. +C + IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 + RECALC = (HBAR+1.E-3*H(IMAX)) .EQ. HBAR + ENDIF +C +C If required, recalculate column SS, using rows IR through MEND. +C + IF (RECALC) THEN + DO 30 J=I,LEND + H(J) = 0.D0 + DO 20 K=IR,MEND + H(J) = H(J) + SCALE(K)*W(K,J)**2 + 20 CONTINUE + 30 CONTINUE +C +C Find column with largest SS. +C + IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 + HBAR = H(IMAX) + ENDIF + RETURN + END +*DECK DWNLT2 + LOGICAL FUNCTION DWNLT2 (ME, MEND, IR, FACTOR, TAU, SCALE, WIC) +C***BEGIN PROLOGUE DWNLT2 +C***SUBSIDIARY +C***PURPOSE Subsidiary to WNLIT +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (WNLT2-S, DWNLT2-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C To test independence of incoming column. +C +C Test the column IC to determine if it is linearly independent +C of the columns already in the basis. In the initial tri. step, +C we usually want the heavy weight ALAMDA to be included in the +C test for independence. In this case, the value of FACTOR will +C have been set to 1.E0 before this procedure is invoked. +C In the potentially rank deficient problem, the value of FACTOR +C will have been set to ALSQ=ALAMDA**2 to remove the effect of the +C heavy weight from the test for independence. +C +C Write new column as partitioned vector +C (A1) number of components in solution so far = NIV +C (A2) M-NIV components +C And compute SN = inverse weighted length of A1 +C RN = inverse weighted length of A2 +C Call the column independent when RN .GT. TAU*SN +C +C***SEE ALSO DWNLIT +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) +C 900604 DP version created from SP version. (RWC) +C***END PROLOGUE DWNLT2 + + DOUBLE PRECISION FACTOR, SCALE(*), TAU, WIC(*) + INTEGER IR, ME, MEND +C + DOUBLE PRECISION RN, SN, T + INTEGER J +C +C***FIRST EXECUTABLE STATEMENT DWNLT2 + SN = 0.E0 + RN = 0.E0 + DO 10 J=1,MEND + T = SCALE(J) + IF (J.LE.ME) T = T/FACTOR + T = T*WIC(J)**2 +C + IF (J.LT.IR) THEN + SN = SN + T + ELSE + RN = RN + T + ENDIF + 10 CONTINUE + DWNLT2 = RN .GT. SN*TAU**2 + RETURN + END +*DECK DWNLT3 + SUBROUTINE DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) +C***BEGIN PROLOGUE DWNLT3 +C***SUBSIDIARY +C***PURPOSE Subsidiary to WNLIT +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (WNLT3-S, DWNLT3-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C Perform column interchange. +C Exchange elements of permuted index vector and perform column +C interchanges. +C +C***SEE ALSO DWNLIT +C***ROUTINES CALLED DSWAP +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) +C 900604 DP version created from SP version. (RWC) +C***END PROLOGUE DWNLT3 + + INTEGER I, IMAX, IPIVOT(*), M, MDW + DOUBLE PRECISION H(*), W(MDW,*) +C + EXTERNAL DSWAP +C + DOUBLE PRECISION T + INTEGER ITEMP +C +C***FIRST EXECUTABLE STATEMENT DWNLT3 + IF (IMAX.NE.I) THEN + ITEMP = IPIVOT(I) + IPIVOT(I) = IPIVOT(IMAX) + IPIVOT(IMAX) = ITEMP +C + CALL DSWAP(M, W(1,IMAX), 1, W(1,I), 1) +C + T = H(IMAX) + H(IMAX) = H(I) + H(I) = T + ENDIF + RETURN + END diff --git a/python/example.py b/python/example.py new file mode 100644 index 0000000..c859fd2 --- /dev/null +++ b/python/example.py @@ -0,0 +1,131 @@ + +# Import the Delaunay Fortran code. +import delsparse + +# Return the source point indices and weights associated with a set of +# interpolation points. Takes points in row-major (C style) format. +# +# INPUTS: +# pts -- 2D Numpy array of float64 points, where each row is one point. +# q -- 2D numpy array of float64 points where Delaunay predictions +# are to be made, where each row is one point. +# +# OUTPUT: +# (indices, weights) -- Where "indices" is a 2D NumPy array of integers +# and each row, i, enumerates the indices of rows in "pts" that are +# the vertices of the simplex containing q[i], and each corresponding +# row of weights (a 2D NumPy array of float64) provides the convex +# weights such that q[i] = np.dot(pts[indices[i]], weights[i]). +# +def delaunay_simplex(pts, q, allow_extrapolation=True, print_errors=True, + parallel=True, pmode=None, chain=None, + ibudget=10000, epsilon=2**(-23), check_spacing=False): + # Enable parallelism. + if parallel: + import os + os.environ["OMP_NESTED"] = "TRUE" + # Import NumPy. + import numpy as np + # Get the predictions from VTdelaunay + pts_in = np.asarray(pts.T, dtype=np.float64, order="F") + p_in = np.asarray(q.T, dtype=np.float64, order="F") + simp_out = np.ones(shape=(p_in.shape[0]+1, p_in.shape[1]), + dtype=np.int32, order="F") + weights_out = np.ones(shape=(p_in.shape[0]+1, p_in.shape[1]), + dtype=np.float64, order="F") + error_out = np.ones(shape=(p_in.shape[1],), + dtype=np.int32, order="F") + if parallel: + delsparse.delaunaysparsep(pts_in.shape[0], pts_in.shape[1], + pts_in, p_in.shape[1], p_in, simp_out, + weights_out, error_out, extrap=100.0, + pmode=pmode, ibudget=ibudget, + eps=epsilon, chain=chain, + exact=check_spacing) + else: + delsparse.delaunaysparses(pts_in.shape[0], pts_in.shape[1], + pts_in, p_in.shape[1], p_in, simp_out, + weights_out, error_out, extrap=100.0, + ibudget=ibudget, eps=epsilon, + chain=chain, exact=check_spacing) + # Remove "extrapolation" errors if the user doesn't care. + if allow_extrapolation: error_out = np.where(error_out == 1, 0, error_out) + else: + if 1 in error_out: + class Extrapolation(Exception): pass + raise(Extrapolation("Encountered extrapolation point when making Delaunay prediction.")) + # Handle any errors that may have occurred. + if (sum(error_out) != 0): + if print_errors: + unique_errors = sorted(np.unique(error_out)) + print(" [Delaunay errors:",end="") + for e in unique_errors: + if (e == 0): continue + indices = tuple(str(i) for i in range(len(error_out)) + if (error_out[i] == e)) + if (len(indices) > 5): indices = indices[:2] + ('...',) + indices[-2:] + print(" %3i"%e,"at","{"+",".join(indices)+"}", end=";") + print("] ") + # Reset the errors to simplex of 1s (to be 0) and weights of 0s. + bad_indices = (error_out > (1 if allow_extrapolation else 0)) + simp_out[:,bad_indices] = 1 + weights_out[:,bad_indices] = 0 + # Adjust the output simplices and weights to be expected shape. + indices = simp_out.T - 1 + weights = weights_out.T + # Return the appropriate shaped pair of points and weights + return (indices, weights) + +# This testing code is placed in a `main` block in case someone +# copies this file to use the 'delaunay_simplex' function. +if __name__ == "__main__": + # List out the "help" documentation. + # help(delsparse) + + # Declare some test function. + import numpy as np + f = lambda x: 3*x[0]+.5*np.cos(8*x[0])+np.sin(5*x[-1]) + np.random.seed(0) + + # Generate test data. + d = 2 + test_size = 1000 + train_sizes = (10, 50, 100, 200, 500, 1000, 5000, 10000) + # Construct the "test" data (q, f_q). + q = np.random.random(size=(test_size,d)) + f_q = np.asarray(list(map(f,q)), dtype=float) + # Construct initial "train" data (x, y). + x = np.random.random(size=(train_sizes[0],d)) + y = np.asarray(list(map(f,x)), dtype=float) + + # Construct a function that converts indices and weights into a real number prediction. + def delaunay_approx(q, points, values): + q = np.array(q, dtype=float) + if len(q.shape) == 1: + inds, wts = delaunay_simplex(points.copy(), np.reshape(q,(1,len(q)))) + return np.dot(values[inds[0]], wts[0]) + else: + inds, wts = delaunay_simplex(points.copy(), q) + vals = values[inds.flatten()].reshape(wts.shape) + return np.sum(vals * wts, axis=1) + + # Show convergence by adding more points to the training set. + for n in train_sizes: + # Add more random points to the "training" set. + if (n > len(x)): + new_points = np.random.random(size=(n-len(x),d)) + new_values = np.asarray(list(map(f,new_points)), dtype=float) + x = np.concatenate( (x,new_points), axis=0 ) + y = np.concatenate( (y,new_values) ) + # Approximate at points. + f_hat = delaunay_approx(q, x, y) + # Compute errors. + abs_error = abs(f_hat - f_q) + avg_abs_error = sum(abs_error) / test_size + max_abs_error = max(abs_error) + # Show errors. + print() + print("Train size:", n) + print(" maximum absolute error: %.2f"%(max_abs_error)) + print(" average absolute error: %.2f"%(avg_abs_error)) + diff --git a/src/LICENSE b/src/LICENSE new file mode 100644 index 0000000..00ce8f0 --- /dev/null +++ b/src/LICENSE @@ -0,0 +1,22 @@ +MIT License + +Copyright (c) 2020 Tyler H. Chang, Layne T. Watson, Thomas C. H. Lux, +Ali R. Butt, Kirk W. Cameron, and Yili Hong. + +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, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +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. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 0000000..7e67fe1 --- /dev/null +++ b/src/Makefile @@ -0,0 +1,31 @@ +FORT = gfortran +CFLAGS = -c +OPTS = -fopenmp +LEGACY = -std=legacy + +all: samples samplep test_install + ./test_install + +test_install: test_install.f90 delsparse.o slatec.o lapack.o blas.o + $(FORT) $(OPTS) test_install.f90 delsparse.o slatec.o lapack.o blas.o -o test_install + +samples: samples.f90 delsparse.o slatec.o lapack.o blas.o + $(FORT) $(OPTS) samples.f90 delsparse.o slatec.o lapack.o blas.o -o samples + +samplep: samplep.f90 delsparse.o slatec.o lapack.o blas.o + $(FORT) $(OPTS) samplep.f90 delsparse.o slatec.o lapack.o blas.o -o samplep + +delsparse.o: delsparse.f90 + $(FORT) $(CFLAGS) $(OPTS) delsparse.f90 -o delsparse.o + +slatec.o : slatec.f + $(FORT) $(CFLAGS) $(OPTS) $(LEGACY) slatec.f -o slatec.o + +lapack.o : lapack.f + $(FORT) $(CFLAGS) $(OPTS) lapack.f -o lapack.o + +blas.o : blas.f + $(FORT) $(CFLAGS) $(OPTS) blas.f -o blas.o + +clean: + rm -f *.o *.mod samples samplep test_install diff --git a/src/README b/src/README new file mode 100644 index 0000000..779ca5a --- /dev/null +++ b/src/README @@ -0,0 +1,83 @@ + ACM TOMS Algorithm 1012: DELAUNAYSPARSE + -- Interpolation via a Sparse Subset of the Delaunay Triangulation + +The package DELAUNAYSPARSE contains serial and parallel codes, written +in FORTRAN 2003 with OpenMP, for performing interpolation in medium to +high dimensions via a sparse subset of the Delaunay triangulation. The +serial driver subroutine is DELAUNAYSPARSES and the parallel driver is +DELAUNAYSPARSEP. Both subroutines use the REAL_PRECISION module from +HOMPACK90 (ACM TOMS Algorithm 777) for approximately 64-bit precision +on all known machines, and the SLATEC subroutine DWNNLS (ACM TOMS +Algorithm 587) for solving an inequality constrained least squares +problem. Additionally, DELAUNAYSPARSE depends on several BLAS and LAPACK +subroutines. The module DELSPARSE_MOD contains the REAL_PRECISION (R8) +data type, and interface blocks for DELAUNAYSPARSES, DELAUNAYSPARSEP, +and DWNNLS. Comments at the top of each subroutine document their +usage, and examples demonstrating their usage are provided in the +sample programs samples.f90 and samplep.f90. + +The physical organization is as follows: + + * The file delsparse.f90 contains the module REAL_PRECISION, + DELSPARSE_MOD, and the driver subroutines DELAUNAYSPARSES, and + DELAUNAYSPARSEP. + * The file slatec.f contains the subroutine DWNNLS and its dependencies + from the SLATEC library. This library has been slightly modified to + comply with the modern Fortran standards. Additionally, legacy + implementations of the BLAS subroutines DROTM and DTROMG have been + included under different names to avoid dependency issues. + * The file samples.f90 contains a sample main program demonstrating the + usage of DELAUNAYSPARSES, with optional arguments. + * The file samplep.f90 contains a sample main program demonstrating the + usage of DELAUNAYSPARSEP, with optional arguments. + * The file test_install.f90 contains a simple test program that checks + whether the installation of DELAUNAYSPARSE appears correct, based + on the output to a small interpolation/extrapolation problem. + * The file sample_input2d.dat contains a sample 2-dimensional input + data set for samples.f90 and samplep.f90. + * The file sample_input4d.dat contains a sample 4-dimensional input + data set for samples.f90 and samplep.f90. + * The files lapack.f and blas.f contain all LAPACK and BLAS + subroutines that are referenced (both directly and indirectly) in + DELAUNAYSPARSE. + * A sample GNU Makefile is provided. + +From here on, the files samples.f90 and samplep.f90 will be referred +to collectively as sample{s|p}.f90 and the files sample_input2d.dat +and sample_input4d.dat will be referred to collectively as +sample_input{2|4}d.dat. + +To check that the installation of DELAUNAYSPARSES and DELAUNAYSPARSEP is +correct, assuming that your Fortran compiler allows mixing fixed format +.f and free format .f90 files in the same compile command, use the command + +$FORT $OPTS delsparse.f90 slatec.f lapack.f blas.f test_install.f90 \ + -o test_install $LIBS + +where '$FORT' is a Fortran 2003 compliant compiler supporting OpenMP +4.5, '$OPTS' is a list of compiler options, and '$LIBS' is a list of +flags to link the BLAS and LAPACK libraries, if those exist on your +system (in which case the files blas.f and lapack.f can be omitted +from the compile command). To run the parallel code, $OPTS must +include the compiler option for OpenMP. + +Then run the tests using + +./test_install + +To compile and link the sample main programs sample{s|p}.f90, use + +$FORT $OPTS delsparse.f90 slatec.f lapack.f blas.f sample{s|p}.f90 \ + -o sample{s|p} $LIBS + +similar to above. To run a sample main program, use + +./sample{s|p} sample_input{2|4}d.dat + +where 'sample_input{2|4}d.dat' could be replaced by any other similarly +formatted data file. + +--------------------------------------------------------------------------- + +For further inquiries, contact +Tyler Chang, tchang@anl.gov. diff --git a/src/blas.f b/src/blas.f new file mode 100644 index 0000000..df991ff --- /dev/null +++ b/src/blas.f @@ -0,0 +1,2206 @@ + +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* ====================================== + + DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* Purpose: +* ============= +* +* DASUM takes the sum of the absolute values. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 3/93 to return if incx .le. 0. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,M,MP1,NINCX +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS,MOD +* .. + DASUM = 0.0D0 + DTEMP = 0.0D0 + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,6) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DTEMP + DABS(DX(I)) + END DO + IF (N.LT.6) THEN + DASUM = DTEMP + RETURN + END IF + END IF + MP1 = M + 1 + DO I = MP1,N,6 + DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) + + $ DABS(DX(I+2)) + DABS(DX(I+3)) + + $ DABS(DX(I+4)) + DABS(DX(I+5)) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + DTEMP = DTEMP + DABS(DX(I)) + END DO + END IF + DASUM = DTEMP + RETURN + END + + SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* Purpose: +* ============= +* +* DAXPY constant times a vector plus a vector. +* uses unrolled loops for increments equal to one. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DA is DOUBLE PRECISION. On entry, DA specifies the scalar alpha. +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +* +* INCY is INTEGER storage spacing between elements of DY +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (DA.EQ.0.0D0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,4) + IF (M.NE.0) THEN + DO I = 1,M + DY(I) = DY(I) + DA*DX(I) + END DO + END IF + IF (N.LT.4) RETURN + MP1 = M + 1 + DO I = MP1,N,4 + DY(I) = DY(I) + DA*DX(I) + DY(I+1) = DY(I+1) + DA*DX(I+1) + DY(I+2) = DY(I+2) + DA*DX(I+2) + DY(I+3) = DY(I+3) + DA*DX(I+3) + END DO + ELSE +* +* code for unequal increments or equal increments +* 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 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN + END + + SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* Purpose: +* ============= +* +* DCOPY copies a vector, x, to a vector, y. +* uses unrolled loops for increments equal to 1. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +* +* INCY is INTEGER storage spacing between elements of DY +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,7) + IF (M.NE.0) THEN + DO I = 1,M + DY(I) = DX(I) + END DO + IF (N.LT.7) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,7 + DY(I) = DX(I) + DY(I+1) = DX(I+1) + DY(I+2) = DX(I+2) + DY(I+3) = DX(I+3) + DY(I+4) = DX(I+4) + DY(I+5) = DX(I+5) + DY(I+6) = DX(I+6) + END DO + ELSE +* +* code for unequal increments or equal increments +* 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 I = 1,N + DY(IY) = DX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN + END + + DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* Purpose: +* ============= +* +* DDOT forms the dot product of two vectors. +* uses unrolled loops for increments equal to one. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +* +* INCY is INTEGER storage spacing between elements of DY +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + DDOT = 0.0D0 + DTEMP = 0.0D0 + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DTEMP + DX(I)*DY(I) + END DO + IF (N.LT.5) THEN + DDOT=DTEMP + RETURN + END IF + END IF + MP1 = M + 1 + DO I = MP1,N,5 + DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) + + $ DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) + END DO + ELSE +* +* code for unequal increments or equal increments +* 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 I = 1,N + DTEMP = DTEMP + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + DDOT = DTEMP + RETURN + END + + SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of +* Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB + LOGICAL NOTA,NOTB +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are +* not +* transposed and set NROWA, NCOLA and NROWB as the number of +* rows +* and columns of A and the number of rows of B +* respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + IF (NOTA) THEN + NROWA = M + NCOLA = K + ELSE + NROWA = K + NCOLA = M + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And if alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF (NOTA) THEN +* +* Form C := alpha*A*B**T + beta*C +* + DO 170 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 130 I = 1,M + C(I,J) = ZERO + 130 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 140 I = 1,M + C(I,J) = BETA*C(I,J) + 140 CONTINUE + END IF + DO 160 L = 1,K + TEMP = ALPHA*B(J,L) + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 200 J = 1,N + DO 190 I = 1,M + TEMP = ZERO + DO 180 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 180 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMM . +* + END + + SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER INCX,INCY,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* Purpose: +* ============= +* +* DGEMV performs one of the matrix-vector operations +* +* y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, +* +* where alpha and beta are scalars, x and y are vectors and A is an +* m by n matrix. +* +* Arguments: +* ========== +* +* TRANS is CHARACTER*1 +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +* +* TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. +* +* TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. +* M is INTEGER +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* +* N is INTEGER +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* +* ALPHA is DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* +* A is DOUBLE PRECISION array, dimension ( LDA, N ) +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* +* LDA is INTEGER +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* +* X is DOUBLE PRECISION array, dimension at least +* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +* Before entry, the incremented array X must contain the +* vector x. +* +* INCX is INTEGER +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* +* BETA is DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* +* Y is DOUBLE PRECISION array, dimension at least +* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY is INTEGER +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* +* Further Details: +* ===================== +* +* Level 2 Blas routine. +* The vector and matrix arguments are not referenced when N = 0, or M = 0 +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 1 + ELSE IF (M.LT.0) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + ELSE IF (INCY.EQ.0) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGEMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF (LSAME(TRANS,'N')) THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (LENX-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (LENY-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,LENY + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,LENY + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,LENY + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,LENY + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(TRANS,'N')) THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF (INCY.EQ.1) THEN + DO 60 J = 1,N + TEMP = ALPHA*X(JX) + DO 50 I = 1,M + Y(I) = Y(I) + TEMP*A(I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + DO 70 I = 1,M + Y(IY) = Y(IY) + TEMP*A(I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = ZERO + DO 90 I = 1,M + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120 J = 1,N + TEMP = ZERO + IX = KX + DO 110 I = 1,M + TEMP = TEMP + A(I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMV . +* + END + + SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of +* Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER(ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JY,KX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (M.LT.0) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGER ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (INCY.GT.0) THEN + JY = 1 + ELSE + JY = 1 - (N-1)*INCY + END IF + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + DO 10 I = 1,M + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + JY = JY + INCY + 20 CONTINUE + ELSE + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (M-1)*INCX + END IF + DO 40 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + IX = KX + DO 30 I = 1,M + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JY = JY + INCY + 40 CONTINUE + END IF +* + RETURN +* +* End of DGER . +* + END + + DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION X(*) +* .. +* +* Purpose: +* ============= +* +* DNRM2 returns the euclidean norm of a vector via the function +* name, so that +* +* DNRM2 := sqrt( x'*x ) +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* Further Details: +* ===================== +* +* -- This version written on 25-October-1982. +* Modified on 14-October-1993 to inline the call to DLASSQ. +* Sven Hammarling, Nag Ltd. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ + INTEGER IX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS,SQRT +* .. + IF (N.LT.1 .OR. INCX.LT.1) THEN + NORM = ZERO + ELSE IF (N.EQ.1) THEN + NORM = ABS(X(1)) + ELSE + SCALE = ZERO + SSQ = ONE +* The following loop is equivalent to this call to the LAPACK +* auxiliary routine: +* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) +* + DO 10 IX = 1,1 + (N-1)*INCX,INCX + IF (X(IX).NE.ZERO) THEN + ABSXI = ABS(X(IX)) + IF (SCALE.LT.ABSXI) THEN + SSQ = ONE + SSQ* (SCALE/ABSXI)**2 + SCALE = ABSXI + ELSE + SSQ = SSQ + (ABSXI/SCALE)**2 + END IF + END IF + 10 CONTINUE + NORM = SCALE*SQRT(SSQ) + END IF +* + DNRM2 = NORM + RETURN +* +* End of DNRM2. +* + END + + SUBROUTINE DSCAL(N,DA,DX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* Purpose: +* ============= +* +* DSCAL scales a vector by a constant. +* uses unrolled loops for increment equal to 1. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DA is DOUBLE PRECISION On entry, DA specifies the scalar alpha. +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 3/93 to return if incx .le. 0. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,M,MP1,NINCX +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + DX(I) = DA*DX(I) + END DO + IF (N.LT.5) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I+1) = DA*DX(I+1) + DX(I+2) = DA*DX(I+2) + DX(I+3) = DA*DX(I+3) + DX(I+4) = DA*DX(I+4) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + DX(I) = DA*DX(I) + END DO + END IF + RETURN + END + + SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* Purpose: +* ============= +* +* DSWAP interchanges two vectors. +* uses unrolled loops for increments equal to 1. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of DX +* +* DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +* +* INCY is INTEGER storage spacing between elements of DY +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,3) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + END DO + IF (N.LT.3) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,3 + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + DTEMP = DX(I+1) + DX(I+1) = DY(I+1) + DY(I+1) = DTEMP + DTEMP = DX(I+2) + DX(I+2) = DY(I+2) + DY(I+2) = DTEMP + END DO + ELSE +* +* code for unequal increments or equal increments 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 I = 1,N + DTEMP = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN + END + + SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of +* Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOUNIT,UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTRMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*A*B. +* + IF (UPPER) THEN + DO 50 J = 1,N + DO 40 K = 1,M + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + DO 30 I = 1,K - 1 + B(I,J) = B(I,J) + TEMP*A(I,K) + 30 CONTINUE + IF (NOUNIT) TEMP = TEMP*A(K,K) + B(K,J) = TEMP + END IF + 40 CONTINUE + 50 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + B(K,J) = TEMP + IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) + DO 60 I = K + 1,M + B(I,J) = B(I,J) + TEMP*A(I,K) + 60 CONTINUE + END IF + 70 CONTINUE + 80 CONTINUE + END IF + ELSE +* +* Form B := alpha*A**T*B. +* + IF (UPPER) THEN + DO 110 J = 1,N + DO 100 I = M,1,-1 + TEMP = B(I,J) + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 90 K = 1,I - 1 + TEMP = TEMP + A(K,I)*B(K,J) + 90 CONTINUE + B(I,J) = ALPHA*TEMP + 100 CONTINUE + 110 CONTINUE + ELSE + DO 140 J = 1,N + DO 130 I = 1,M + TEMP = B(I,J) + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 120 K = I + 1,M + TEMP = TEMP + A(K,I)*B(K,J) + 120 CONTINUE + B(I,J) = ALPHA*TEMP + 130 CONTINUE + 140 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*A. +* + IF (UPPER) THEN + DO 180 J = N,1,-1 + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = 1,M + B(I,J) = TEMP*B(I,J) + 150 CONTINUE + DO 170 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 160 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + ELSE + DO 220 J = 1,N + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 190 I = 1,M + B(I,J) = TEMP*B(I,J) + 190 CONTINUE + DO 210 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 200 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 200 CONTINUE + END IF + 210 CONTINUE + 220 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*A**T. +* + IF (UPPER) THEN + DO 260 K = 1,N + DO 240 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + TEMP = ALPHA*A(J,K) + DO 230 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 230 CONTINUE + END IF + 240 CONTINUE + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(K,K) + IF (TEMP.NE.ONE) THEN + DO 250 I = 1,M + B(I,K) = TEMP*B(I,K) + 250 CONTINUE + END IF + 260 CONTINUE + ELSE + DO 300 K = N,1,-1 + DO 280 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + TEMP = ALPHA*A(J,K) + DO 270 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 270 CONTINUE + END IF + 280 CONTINUE + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(K,K) + IF (TEMP.NE.ONE) THEN + DO 290 I = 1,M + B(I,K) = TEMP*B(I,K) + 290 CONTINUE + END IF + 300 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRMM . +* + END + + SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of +* Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER(ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTRMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := A*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*A(I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 I = 1,J - 1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*A(I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 70 I = N,J + 1,-1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 100 J = N,1,-1 + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 90 I = J - 1,1,-1 + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + X(J) = TEMP + 100 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 120 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 110 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + A(I,J)*X(IX) + 110 CONTINUE + X(JX) = TEMP + JX = JX - INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = 1,N + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 130 I = J + 1,N + TEMP = TEMP + A(I,J)*X(I) + 130 CONTINUE + X(J) = TEMP + 140 CONTINUE + ELSE + JX = KX + DO 160 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + A(I,J)*X(IX) + 150 CONTINUE + X(JX) = TEMP + JX = JX + INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRMV . +* + END + + SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*) +* .. +* +* Purpose: +* ============= +* +* DTRSM solves one of the matrix equations +* +* op( A )*X = alpha*B, or X*op( A ) = alpha*B, +* +* where alpha is a scalar, X and B are m by n matrices, A is a unit, or +* non-unit, upper or lower triangular matrix and op( A ) is one of +* +* op( A ) = A or op( A ) = A**T. +* +* The matrix X is overwritten on B. +* +* Arguments: +* ========== +* +* SIDE is CHARACTER*1 +* On entry, SIDE specifies whether op( A ) appears on the left +* or right of X as follows: +* +* SIDE = 'L' or 'l' op( A )*X = alpha*B. +* +* SIDE = 'R' or 'r' X*op( A ) = alpha*B. +* +* UPLO is CHARACTER*1 +* On entry, UPLO specifies whether the matrix A is an upper or +* lower triangular matrix as follows: +* +* UPLO = 'U' or 'u' A is an upper triangular matrix. +* +* UPLO = 'L' or 'l' A is a lower triangular matrix. +* +* TRANSA is CHARACTER*1 +* On entry, TRANSA specifies the form of op( A ) to be used in +* the matrix multiplication as follows: +* +* TRANSA = 'N' or 'n' op( A ) = A. +* +* TRANSA = 'T' or 't' op( A ) = A**T. +* +* TRANSA = 'C' or 'c' op( A ) = A**T. +* +* DIAG is CHARACTER*1 +* On entry, DIAG specifies whether or not A is unit triangular +* as follows: +* +* DIAG = 'U' or 'u' A is assumed to be unit triangular. +* +* DIAG = 'N' or 'n' A is not assumed to be unit +* triangular. +* +* M is INTEGER +* On entry, M specifies the number of rows of B. M must be at +* least zero. +* +* N is INTEGER +* On entry, N specifies the number of columns of B. N must be +* at least zero. +* +* ALPHA is DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. When alpha is +* zero then A is not referenced and B need not be set before +* entry. +* +* A is DOUBLE PRECISION array, dimension ( LDA, k ), +* where k is m when SIDE = 'L' or 'l' +* and k is n when SIDE = 'R' or 'r'. +* Before entry with UPLO = 'U' or 'u', the leading k by k +* upper triangular part of the array A must contain the upper +* triangular matrix and the strictly lower triangular part of +* A is not referenced. +* Before entry with UPLO = 'L' or 'l', the leading k by k +* lower triangular part of the array A must contain the lower +* triangular matrix and the strictly upper triangular part of +* A is not referenced. +* Note that when DIAG = 'U' or 'u', the diagonal elements of +* A are not referenced either, but are assumed to be unity. +* +* LDA is INTEGER +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When SIDE = 'L' or 'l' then +* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +* then LDA must be at least max( 1, n ). +* +* B is DOUBLE PRECISION array, dimension ( LDB, N ) +* Before entry, the leading m by n part of the array B must +* contain the right-hand side matrix B, and on exit is +* overwritten by the solution matrix X. +* +* LDB is INTEGER +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. LDB must be at least +* max( 1, m ). +* +* Further Details: +* ===================== +* +* Level 3 Blas routine. +* +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOUNIT,UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER(ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DTRSM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*inv( A )*B. +* + IF (UPPER) THEN + DO 60 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 30 I = 1,M + B(I,J) = ALPHA*B(I,J) + 30 CONTINUE + END IF + DO 50 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 40 I = 1,K - 1 + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 40 CONTINUE + END IF + 50 CONTINUE + 60 CONTINUE + ELSE + DO 100 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 70 I = 1,M + B(I,J) = ALPHA*B(I,J) + 70 CONTINUE + END IF + DO 90 K = 1,M + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 80 I = K + 1,M + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 80 CONTINUE + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form B := alpha*inv( A**T )*B. +* + IF (UPPER) THEN + DO 130 J = 1,N + DO 120 I = 1,M + TEMP = ALPHA*B(I,J) + DO 110 K = 1,I - 1 + TEMP = TEMP - A(K,I)*B(K,J) + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + B(I,J) = TEMP + 120 CONTINUE + 130 CONTINUE + ELSE + DO 160 J = 1,N + DO 150 I = M,1,-1 + TEMP = ALPHA*B(I,J) + DO 140 K = I + 1,M + TEMP = TEMP - A(K,I)*B(K,J) + 140 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + B(I,J) = TEMP + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*inv( A ). +* + IF (UPPER) THEN + DO 210 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 170 I = 1,M + B(I,J) = ALPHA*B(I,J) + 170 CONTINUE + END IF + DO 190 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + DO 180 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 180 CONTINUE + END IF + 190 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 200 I = 1,M + B(I,J) = TEMP*B(I,J) + 200 CONTINUE + END IF + 210 CONTINUE + ELSE + DO 260 J = N,1,-1 + IF (ALPHA.NE.ONE) THEN + DO 220 I = 1,M + B(I,J) = ALPHA*B(I,J) + 220 CONTINUE + END IF + DO 240 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + DO 230 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 230 CONTINUE + END IF + 240 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 250 I = 1,M + B(I,J) = TEMP*B(I,J) + 250 CONTINUE + END IF + 260 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*inv( A**T ). +* + IF (UPPER) THEN + DO 310 K = N,1,-1 + IF (NOUNIT) THEN + TEMP = ONE/A(K,K) + DO 270 I = 1,M + B(I,K) = TEMP*B(I,K) + 270 CONTINUE + END IF + DO 290 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + TEMP = A(J,K) + DO 280 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 280 CONTINUE + END IF + 290 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 300 I = 1,M + B(I,K) = ALPHA*B(I,K) + 300 CONTINUE + END IF + 310 CONTINUE + ELSE + DO 360 K = 1,N + IF (NOUNIT) THEN + TEMP = ONE/A(K,K) + DO 320 I = 1,M + B(I,K) = TEMP*B(I,K) + 320 CONTINUE + END IF + DO 340 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + TEMP = A(J,K) + DO 330 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 330 CONTINUE + END IF + 340 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 350 I = 1,M + B(I,K) = ALPHA*B(I,K) + 350 CONTINUE + END IF + 360 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRSM . +* + END + + INTEGER FUNCTION IDAMAX(N,DX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* Purpose: +* ============= +* +* IDAMAX finds the index of the first element having maximum absolute value. +* +* Arguments: +* ========== +* +* N is INTEGER number of elements in input vector(s) +* +* DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +* +* INCX is INTEGER storage spacing between elements of SX +* +* Further Details: +* ===================== +* +* jack dongarra, linpack, 3/11/78. +* modified 3/93 to return if incx .le. 0. +* modified 12/3/93, array(1) declarations changed to array(*) +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DMAX + INTEGER I,IX +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS +* .. + IDAMAX = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + IDAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DMAX = DABS(DX(1)) + DO I = 2,N + IF (DABS(DX(I)).GT.DMAX) THEN + IDAMAX = I + DMAX = DABS(DX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + DMAX = DABS(DX(1)) + IX = IX + INCX + DO I = 2,N + IF (DABS(DX(IX)).GT.DMAX) THEN + IDAMAX = I + DMAX = DABS(DX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN + END + + LOGICAL FUNCTION LSAME(CA,CB) +* +* -- Reference BLAS level1 routine (version 3.1) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER CA,CB +* .. +* +* Purpose: +* ============= +* +* LSAME returns .TRUE. if CA is the same letter as CB regardless of +* case. +* +* Arguments: +* ========== +* +* CA is CHARACTER*1 +* CB is CHARACTER*1 +* CA and CB specify the single characters to be compared. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA,INTB,ZCODE +* .. +* +* Test if the characters are equal +* + LSAME = CA .EQ. CB + IF (LSAME) RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + ZCODE = ICHAR('Z') +* +* Use 'Z' rather than 'A' so that ASCII can be detected on Prime +* machines, on which ICHAR returns a value with bit 8 set. +* ICHAR('A') on Prime machines returns 193 which is the same as +* ICHAR('A') on an EBCDIC machine. +* + INTA = ICHAR(CA) + INTB = ICHAR(CB) +* + IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 + IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 +* + ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.129 .AND. INTA.LE.137 .OR. + + INTA.GE.145 .AND. INTA.LE.153 .OR. + + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 + IF (INTB.GE.129 .AND. INTB.LE.137 .OR. + + INTB.GE.145 .AND. INTB.LE.153 .OR. + + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 +* + ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 + IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 + END IF + LSAME = INTA .EQ. INTB +* +* RETURN +* +* End of LSAME +* + END + + SUBROUTINE XERBLA( SRNAME, INFO ) +* +* -- Reference BLAS level1 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER*(*) SRNAME + INTEGER INFO +* .. +* +* Purpose: +* ============= +* +* XERBLA is an error handler for the LAPACK routines. +* It is called by an LAPACK routine if an input parameter has an +* invalid value. A message is printed and execution stops. +* +* Installers may consider modifying the STOP statement in order to +* call system-specific exception-handling facilities. +* +* Arguments: +* ========== +* +* SRNAME is CHARACTER*(*) +* The name of the routine which called XERBLA. +* +* INFO is INTEGER +* The position of the invalid parameter in the parameter list +* of the calling routine. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM +* .. +* .. Executable Statements .. +* + WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO +* + STOP +* + 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END + diff --git a/src/lapack.f b/src/lapack.f new file mode 100644 index 0000000..3dff8b8 --- /dev/null +++ b/src/lapack.f @@ -0,0 +1,4369 @@ + SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, +* -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER INB, INBMIN, IXOVER + PARAMETER( INB = 1, INBMIN = 2, IXOVER = 3 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, + $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN +* .. +* .. External Subroutines .. + EXTERNAL DGEQRF, DLAQP2, DLAQPS, DORMQR, DSWAP, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DNRM2 + EXTERNAL ILAENV, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE + IWS = 3*N + 1 + NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = 2*N + ( N + 1 )*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQP3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Move initial columns up front. +* + NFXD = 1 + DO 10 J = 1, N + IF( JPVT( J ).NE.0 ) THEN + IF( J.NE.NFXD ) THEN + CALL DSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 ) + JPVT( J ) = JPVT( NFXD ) + JPVT( NFXD ) = J + ELSE + JPVT( J ) = J + END IF + NFXD = NFXD + 1 + ELSE + JPVT( J ) = J + END IF + 10 CONTINUE + NFXD = NFXD - 1 +* +* Factorize fixed columns +* ======================= +* +* Compute the QR factorization of fixed columns and update +* remaining columns. +* + IF( NFXD.GT.0 ) THEN + NA = MIN( M, NFXD ) +*CC CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) + CALL DGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO ) + IWS = MAX( IWS, INT( WORK( 1 ) ) ) + IF( NA.LT.N ) THEN +*CC CALL DORM2R( 'LEFT', 'TRANSPOSE', M, N-NA, NA, A, LDA, +*CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) + CALL DORMQR( 'LEFT', 'TRANSPOSE', M, N-NA, NA, A, LDA, TAU, + $ A( 1, NA+1 ), LDA, WORK, LWORK, INFO ) + IWS = MAX( IWS, INT( WORK( 1 ) ) ) + END IF + END IF +* +* Factorize free columns +* ====================== +* + IF( NFXD.LT.MINMN ) THEN +* + SM = M - NFXD + SN = N - NFXD + SMINMN = MINMN - NFXD +* +* Determine the block size. +* + NB = ILAENV( INB, 'DGEQRF', ' ', SM, SN, -1, -1 ) + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked +* code. +* + NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', SM, SN, -1, + $ -1 ) ) +* +* + IF( NX.LT.SMINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + MINWS = 2*SN + ( SN+1 )*NB + IWS = MAX( IWS, MINWS ) + IF( LWORK.LT.MINWS ) THEN +* +* Not enough workspace to use optimal NB: Reduce NB and +* determine the minimum value of NB. +* + NB = ( LWORK-2*SN ) / ( SN+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', SM, N, + $ -1, -1 ) ) +* +* + END IF + END IF + END IF +* +* Initialize partial column norms. The first N elements of work +* store the exact column norms. +* + DO 20 J = NFXD + 1, N + WORK( J ) = DNRM2( SM, A( NFXD+1, J ), 1 ) + WORK( N+J ) = WORK( J ) + 20 CONTINUE +* + IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. + $ ( NX.LT.SMINMN ) ) THEN +* +* Use blocked code initially. +* + J = NFXD + 1 +* +* Compute factorization: while loop. +* +* + TOPBMN = MINMN - NX + 30 CONTINUE + IF( J.LE.TOPBMN ) THEN + JB = MIN( NB, TOPBMN-J+1 ) +* +* Factorize JB columns among columns J:N. +* + CALL DLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, + $ JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 ) +* + J = J + FJB + GO TO 30 + END IF + ELSE + J = NFXD + 1 + END IF +* +* Use unblocked code to factor the last or only block. +* +* + IF( J.LE.MINMN ) + $ CALL DLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), + $ TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ) ) +* + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of DGEQP3 +* + END + SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DGEQR2 computes a QR factorization of a real m by n matrix A: +* A = Q * R. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the m by n matrix A. +* On exit, the elements on and above the diagonal of the array +* contain the min(m,n) by n upper trapezoidal matrix R (R is +* upper triangular if m >= n); the elements below the diagonal, +* with the array TAU, represent the orthogonal matrix Q as a +* product of elementary reflectors (see Further Details). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) +* The scalar factors of the elementary reflectors (see Further +* Details). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further Details +* =============== +* +* The matrix Q is represented as a product of elementary reflectors +* +* Q = H(1) H(2) . . . H(k), where k = min(m,n). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**T +* +* where tau is a real scalar, and v is a real vector with +* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), +* and tau in TAU(i). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K + DOUBLE PRECISION AII +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQR2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = 1, K +* +* Generate elementary reflector H(i) to annihilate A(i+1:m,i) +* + CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, + $ TAU( I ) ) + IF( I.LT.N ) THEN +* +* Apply H(i) to A(i:m,i+1:n) from the left +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + A( I, I ) = AII + END IF + 10 CONTINUE + RETURN +* +* End of DGEQR2 +* + END + SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DGEQRF computes a QR factorization of a real M-by-N matrix A: +* A = Q * R. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the M-by-N matrix A. +* On exit, the elements on and above the diagonal of the array +* contain the min(M,N)-by-N upper trapezoidal matrix R (R is +* upper triangular if m >= n); the elements below the diagonal, +* with the array TAU, represent the orthogonal matrix Q as a +* product of min(m,n) elementary reflectors (see Further +* Details). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) +* The scalar factors of the elementary reflectors (see Further +* Details). +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension +* (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= max(1,N). +* For optimum performance LWORK >= N*NB, where NB is +* the optimal blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further Details +* =============== +* +* The matrix Q is represented as a product of elementary reflectors +* +* Q = H(1) H(2) . . . H(k), where k = min(m,n). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**T +* +* where tau is a real scalar, and v is a real vector with +* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), +* and tau in TAU(i). +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQRF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + K = MIN( M, N ) + IF( K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, + $ -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code initially +* + DO 10 I = 1, K - NX, NB + IB = MIN( K-I+1, NB ) +* +* Compute the QR factorization of the current block +* A(i:m,i:i+ib-1) +* + CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) + IF( I+IB.LE.N ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, + $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H**T to A(i:m,i+ib:n) from the left +* + CALL DLARFB( 'Left', 'Transpose', 'Forward', + $ 'Columnwise', M-I+1, N-I-IB+1, IB, + $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), + $ LDA, WORK( IB+1 ), LDWORK ) + END IF + 10 CONTINUE + ELSE + I = 1 + END IF +* +* Use unblocked code to factor the last or only block. +* + IF( I.LE.K ) + $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* + WORK( 1 ) = IWS + RETURN +* +* End of DGEQRF +* + END + SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DGETF2 computes an LU factorization of a general m-by-n matrix A +* using partial pivoting with row interchanges. +* +* The factorization has the form +* A = P * L * U +* where P is a permutation matrix, L is lower triangular with unit +* diagonal elements (lower trapezoidal if m > n), and U is upper +* triangular (upper trapezoidal if m < n). +* +* This is the right-looking Level 2 BLAS version of the algorithm. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the m by n matrix to be factored. +* On exit, the factors L and U from the factorization +* A = P*L*U; the unit diagonal elements of L are not stored. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* IPIV (output) INTEGER array, dimension (min(M,N)) +* The pivot indices; for 1 <= i <= min(M,N), row i of the +* matrix was interchanged with row IPIV(i). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -k, the k-th argument had an illegal value +* > 0: if INFO = k, U(k,k) is exactly zero. The factorization +* has been completed, but the factor U is exactly +* singular, and division by zero will occur if it is used +* to solve a system of equations. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION SFMIN + INTEGER I, J, JP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER IDAMAX + EXTERNAL DLAMCH, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL DGER, DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Compute machine safe minimum +* + SFMIN = DLAMCH('S') +* + DO 10 J = 1, MIN( M, N ) +* +* Find pivot and test for singularity. +* + JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) + IPIV( J ) = JP + IF( A( JP, J ).NE.ZERO ) THEN +* +* Apply the interchange to columns 1:N. +* + IF( JP.NE.J ) + $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) +* +* Compute elements J+1:M of J-th column. +* + IF( J.LT.M ) THEN + IF( ABS(A( J, J )) .GE. SFMIN ) THEN + CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) + ELSE + DO 20 I = 1, M-J + A( J+I, J ) = A( J+I, J ) / A( J, J ) + 20 CONTINUE + END IF + END IF +* + ELSE IF( INFO.EQ.0 ) THEN +* + INFO = J + END IF +* + IF( J.LT.MIN( M, N ) ) THEN +* +* Update trailing submatrix. +* + CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, + $ A( J+1, J+1 ), LDA ) + END IF + 10 CONTINUE + RETURN +* +* End of DGETF2 +* + END + SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DGETRF computes an LU factorization of a general M-by-N matrix A +* using partial pivoting with row interchanges. +* +* The factorization has the form +* A = P * L * U +* where P is a permutation matrix, L is lower triangular with unit +* diagonal elements (lower trapezoidal if m > n), and U is upper +* triangular (upper trapezoidal if m < n). +* +* This is the right-looking Level 3 BLAS version of the algorithm. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the M-by-N matrix to be factored. +* On exit, the factors L and U from the factorization +* A = P*L*U; the unit diagonal elements of L are not stored. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* IPIV (output) INTEGER array, dimension (min(M,N)) +* The pivot indices; for 1 <= i <= min(M,N), row i of the +* matrix was interchanged with row IPIV(i). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, U(i,i) is exactly zero. The factorization +* has been completed, but the factor U is exactly +* singular, and division by zero will occur if it is used +* to solve a system of equations. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IINFO, J, JB, NB +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN +* +* Use unblocked code. +* + CALL DGETF2( M, N, A, LDA, IPIV, INFO ) + ELSE +* +* Use blocked code. +* + DO 20 J = 1, MIN( M, N ), NB + JB = MIN( MIN( M, N )-J+1, NB ) +* +* Factor diagonal and subdiagonal blocks and test for exact +* singularity. +* + CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) +* +* Adjust INFO and the pivot indices. +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + J - 1 + DO 10 I = J, MIN( M, J+JB-1 ) + IPIV( I ) = J - 1 + IPIV( I ) + 10 CONTINUE +* +* Apply interchanges to columns 1:J-1. +* + CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) +* + IF( J+JB.LE.N ) THEN +* +* Apply interchanges to columns J+JB:N. +* + CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, + $ IPIV, 1 ) +* +* Compute block row of U. +* + CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, + $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), + $ LDA ) + IF( J+JB.LE.M ) THEN +* +* Update trailing submatrix. +* + CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, + $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, + $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), + $ LDA ) + END IF + END IF + 20 CONTINUE + END IF + RETURN +* +* End of DGETRF +* + END + SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* Purpose +* ======= +* +* DGETRS solves a system of linear equations +* A * X = B or A**T * X = B +* with a general N-by-N matrix A using the LU factorization computed +* by DGETRF. +* +* Arguments +* ========= +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T* X = B (Transpose) +* = 'C': A**T* X = B (Conjugate transpose = Transpose) +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrix B. NRHS >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The factors L and U from the factorization A = P*L*U +* as computed by DGETRF. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* IPIV (input) INTEGER array, dimension (N) +* The pivot indices from DGETRF; for 1<=i<=N, row i of the +* matrix was interchanged with row IPIV(i). +* +* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) +* On entry, the right hand side matrix B. +* On exit, the solution matrix X. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLASWP, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( NOTRAN ) THEN +* +* Solve A * X = B. +* +* Apply row interchanges to the right hand sides. +* + CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) +* +* Solve L*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve U*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, A, LDA, B, LDB ) + ELSE +* +* Solve A**T * X = B. +* +* Solve U**T *X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve L**T *X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, + $ A, LDA, B, LDB ) +* +* Apply row interchanges to the solution vectors. +* + CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) + END IF +* + RETURN +* +* End of DGETRS +* + END + DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y +* .. +* +* Purpose +* ======= +* +* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary +* overflow. +* +* Arguments +* ========= +* +* X (input) DOUBLE PRECISION +* Y (input) DOUBLE PRECISION +* X and Y specify the values x and y. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION W, XABS, YABS, Z +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + XABS = ABS( X ) + YABS = ABS( Y ) + W = MAX( XABS, YABS ) + Z = MIN( XABS, YABS ) + IF( Z.EQ.ZERO ) THEN + DLAPY2 = W + ELSE + DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) + END IF + RETURN +* +* End of DLAPY2 +* + END + SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, + $ WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, +* -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER LDA, M, N, OFFSET +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, MN, OFFPI, PVT + DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 +* .. +* .. Executable Statements .. +* + MN = MIN( M-OFFSET, N ) + TOL3Z = SQRT(DLAMCH('EPSILON')) +* +* Compute factorization. +* + DO 20 I = 1, MN +* + OFFPI = OFFSET + I +* +* Determine ith pivot column and swap if necessary. +* + PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 ) +* + IF( PVT.NE.I ) THEN + CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( I ) + JPVT( I ) = ITEMP + VN1( PVT ) = VN1( I ) + VN2( PVT ) = VN2( I ) + END IF +* +* Generate elementary reflector H(i). +* + IF( OFFPI.LT.M ) THEN + CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, + $ TAU( I ) ) + ELSE + CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) + END IF +* + IF( I.LT.N ) THEN +* +* Apply H(i)**T to A(offset+i:m,i+1:n) from the left. +* + AII = A( OFFPI, I ) + A( OFFPI, I ) = ONE + CALL DLARF( 'LEFT', M-OFFPI+1, N-I, A( OFFPI, I ), 1, + $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) + A( OFFPI, I ) = AII + END IF +* +* Update partial column norms. +* + DO 10 J = I + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following 4 lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN + IF( OFFPI.LT.M ) THEN + VN1( J ) = DNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) + VN2( J ) = VN1( J ) + ELSE + VN1( J ) = ZERO + VN2( J ) = ZERO + END IF + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + 10 CONTINUE +* + 20 CONTINUE +* + RETURN +* +* End of DLAQP2 +* + END + SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, + $ VN2, AUXV, F, LDF ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, +* -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER KB, LDA, LDF, M, N, NB, OFFSET +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), + $ VN1( * ), VN2( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK + DOUBLE PRECISION AKK, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, NINT, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 +* .. +* .. Executable Statements .. +* + LASTRK = MIN( M, N+OFFSET ) + LSTICC = 0 + K = 0 + TOL3Z = SQRT(DLAMCH('EPSILON')) +* +* Beginning of while loop. +* + 10 CONTINUE + IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN + K = K + 1 + RK = OFFSET + K +* +* Determine ith pivot column and swap if necessary +* + PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) + IF( PVT.NE.K ) THEN + CALL DSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 ) + CALL DSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( K ) + JPVT( K ) = ITEMP + VN1( PVT ) = VN1( K ) + VN2( PVT ) = VN2( K ) + END IF +* +* Apply previous Householder reflectors to column K: +* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**T. +* + IF( K.GT.1 ) THEN + CALL DGEMV( 'NO TRANSPOSE', M-RK+1, K-1, -ONE, A( RK, 1 ), + $ LDA, F( K, 1 ), LDF, ONE, A( RK, K ), 1 ) + END IF +* +* Generate elementary reflector H(k). +* + IF( RK.LT.M ) THEN + CALL DLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) + ELSE + CALL DLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) + END IF +* + AKK = A( RK, K ) + A( RK, K ) = ONE +* +* Compute Kth column of F: +* +* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**T*A(RK:M,K). +* + IF( K.LT.N ) THEN + CALL DGEMV( 'TRANSPOSE', M-RK+1, N-K, TAU( K ), + $ A( RK, K+1 ), LDA, A( RK, K ), 1, ZERO, + $ F( K+1, K ), 1 ) + END IF +* +* Padding F(1:K,K) with zeros. +* + DO 20 J = 1, K + F( J, K ) = ZERO + 20 CONTINUE +* +* Incremental updating of F: +* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**T +* *A(RK:M,K). +* + IF( K.GT.1 ) THEN + CALL DGEMV( 'TRANSPOSE', M-RK+1, K-1, -TAU( K ), A( RK, 1 ), + $ LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 ) +* + CALL DGEMV( 'NO TRANSPOSE', N, K-1, ONE, F( 1, 1 ), LDF, + $ AUXV( 1 ), 1, ONE, F( 1, K ), 1 ) + END IF +* +* Update the current row of A: +* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**T. +* + IF( K.LT.N ) THEN + CALL DGEMV( 'NO TRANSPOSE', N-K, K, -ONE, F( K+1, 1 ), LDF, + $ A( RK, 1 ), LDA, ONE, A( RK, K+1 ), LDA ) + END IF +* +* Update partial column norms. +* + IF( RK.LT.LASTRK ) THEN + DO 30 J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following 4 lines follow from the analysis +* in +* Lapack Working Note 176. +* + TEMP = ABS( A( RK, J ) ) / VN1( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN + VN2( J ) = DBLE( LSTICC ) + LSTICC = J + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE + END IF +* + A( RK, K ) = AKK +* +* End of while loop. +* + GO TO 10 + END IF + KB = K + RK = OFFSET + KB +* +* Apply the block reflector to the rest of the matrix: +* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - +* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**T. +* + IF( KB.LT.MIN( N, M-OFFSET ) ) THEN + CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M-RK, N-KB, KB, -ONE, + $ A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, + $ A( RK+1, KB+1 ), LDA ) + END IF +* +* Recomputation of difficult columns. +* + 40 CONTINUE + IF( LSTICC.GT.0 ) THEN + ITEMP = NINT( VN2( LSTICC ) ) + VN1( LSTICC ) = DNRM2( M-RK, A( RK+1, LSTICC ), 1 ) +* +* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* SNRM2 does not fail on vectors with norm below the value of +* SQRT(DLAMCH('S')) +* + VN2( LSTICC ) = VN1( LSTICC ) + LSTICC = ITEMP + GO TO 40 + END IF +* + RETURN +* +* End of DLAQPS +* + END + SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DLARF applies a real elementary reflector H to a real m by n matrix +* C, from either the left or the right. H is represented in the form +* +* H = I - tau * v * v**T +* +* where tau is a real scalar and v is a real vector. +* +* If tau = 0, then H is taken to be the unit matrix. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': form H * C +* = 'R': form C * H +* +* M (input) INTEGER +* The number of rows of the matrix C. +* +* N (input) INTEGER +* The number of columns of the matrix C. +* +* V (input) DOUBLE PRECISION array, dimension +* (1 + (M-1)*abs(INCV)) if SIDE = 'L' +* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +* The vector v in the representation of H. V is not used if +* TAU = 0. +* +* INCV (input) INTEGER +* The increment between elements of v. INCV <> 0. +* +* TAU (input) DOUBLE PRECISION +* The value tau in the representation of H. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m by n matrix C. +* On exit, C is overwritten by the matrix H * C if SIDE = 'L', +* or C * H if SIDE = 'R'. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension +* (N) if SIDE = 'L' +* or (M) if SIDE = 'R' +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILADLR, ILADLC + EXTERNAL LSAME, ILADLR, ILADLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 0 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V. + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILADLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILADLR(M, LASTV, C, LDC) + END IF + END IF +! Note that lastc.eq.0 renders the BLAS operations null; no special +! case is needed at this level. + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) +* + CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, + $ ZERO, WORK, 1 ) +* +* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * +* w(1:lastc,1)**T +* + CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) +* + CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, + $ V, INCV, ZERO, WORK, 1 ) +* +* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * +* v(1:lastv,1)**T +* + CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) + END IF + END IF + RETURN +* +* End of DLARF +* + END + SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, + $ T, LDT, C, LDC, WORK, LDWORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), + $ WORK( LDWORK, * ) +* .. +* +* Purpose +* ======= +* +* DLARFB applies a real block reflector H or its transpose H**T to a +* real m by n matrix C, from either the left or the right. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply H or H**T from the Left +* = 'R': apply H or H**T from the Right +* +* TRANS (input) CHARACTER*1 +* = 'N': apply H (No transpose) +* = 'T': apply H**T (Transpose) +* +* DIRECT (input) CHARACTER*1 +* Indicates how H is formed from a product of elementary +* reflectors +* = 'F': H = H(1) H(2) . . . H(k) (Forward) +* = 'B': H = H(k) . . . H(2) H(1) (Backward) +* +* STOREV (input) CHARACTER*1 +* Indicates how the vectors which define the elementary +* reflectors are stored: +* = 'C': Columnwise +* = 'R': Rowwise +* +* M (input) INTEGER +* The number of rows of the matrix C. +* +* N (input) INTEGER +* The number of columns of the matrix C. +* +* K (input) INTEGER +* The order of the matrix T (= the number of elementary +* reflectors whose product defines the block reflector). +* +* V (input) DOUBLE PRECISION array, dimension +* (LDV,K) if STOREV = 'C' +* (LDV,M) if STOREV = 'R' and SIDE = 'L' +* (LDV,N) if STOREV = 'R' and SIDE = 'R' +* The matrix V. See Further Details. +* +* LDV (input) INTEGER +* The leading dimension of the array V. +* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); +* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); +* if STOREV = 'R', LDV >= K. +* +* T (input) DOUBLE PRECISION array, dimension (LDT,K) +* The triangular k by k matrix T in the representation of the +* block reflector. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= K. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m by n matrix C. +* On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) +* +* LDWORK (input) INTEGER +* The leading dimension of the array WORK. +* If SIDE = 'L', LDWORK >= max(1,N); +* if SIDE = 'R', LDWORK >= max(1,M). +* +* Further Details +* =============== +* +* The shape of the matrix V and the storage of the vectors which define +* the H(i) is best illustrated by the following example with n = 5 and +* k = 3. The elements equal to 1 are not stored; the corresponding +* array elements are modified but restored on exit. The rest of the +* array is not used. +* +* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +* +* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +* ( v1 1 ) ( 1 v2 v2 v2 ) +* ( v1 v2 1 ) ( 1 v3 v3 ) +* ( v1 v2 v3 ) +* ( v1 v2 v3 ) +* +* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +* +* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +* ( v1 v2 v3 ) ( v2 v2 v2 1 ) +* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +* ( 1 v3 ) +* ( 1 ) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + CHARACTER TRANST + INTEGER I, J, LASTV, LASTC +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILADLR, ILADLC + EXTERNAL LSAME, ILADLR, ILADLC +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DTRMM +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* + IF( LSAME( TRANS, 'N' ) ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* + IF( LSAME( STOREV, 'C' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 ) (first K rows) +* ( V2 ) +* where V1 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in +* WORK) +* +* W := C1**T +* + DO 10 J = 1, K + CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 10 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2**T *V2 +* + CALL DGEMM( 'Transpose', 'No transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**T +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - V2 * W**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTV-K, LASTC, K, + $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**T +* + DO 30 J = 1, K + DO 20 I = 1, LASTC + C( J, I ) = C( J, I ) - WORK( I, J ) + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C1 +* + DO 40 J = 1, K + CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + 40 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2 * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**T +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - W * V2**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, LASTV-K, K, + $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 60 J = 1, K + DO 50 I = 1, LASTC + C( I, J ) = C( I, J ) - WORK( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + ELSE +* +* Let V = ( V1 ) +* ( V2 ) (last K rows) +* where V2 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in +* WORK) +* +* W := C2**T +* + DO 70 J = 1, K + CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, + $ WORK( 1, J ), 1 ) + 70 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1**T*V1 +* + CALL DGEMM( 'Transpose', 'No transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**T +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - V1 * W**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) + END IF +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W**T +* + DO 90 J = 1, K + DO 80 I = 1, LASTC + C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C2 +* + DO 100 J = 1, K + CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 100 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1 * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**T +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - W * V1**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, + $ ONE, C, LDC ) + END IF +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W +* + DO 120 J = 1, K + DO 110 I = 1, LASTC + C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) + 110 CONTINUE + 120 CONTINUE + END IF + END IF +* + ELSE IF( LSAME( STOREV, 'R' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 V2 ) (V1: first K columns) +* where V1 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) +* (stored in WORK) +* +* W := C1**T +* + DO 130 J = 1, K + CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 130 CONTINUE +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2**T*V2**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**T * W**T +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - V2**T * W**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTV-K, LASTC, K, + $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, + $ ONE, C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**T +* + DO 150 J = 1, K + DO 140 I = 1, LASTC + C( J, I ) = C( J, I ) - WORK( I, J ) + 140 CONTINUE + 150 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) +* +* W := C1 +* + DO 160 J = 1, K + CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + 160 CONTINUE +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2 * V2**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - W * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, LASTV-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, + $ ONE, C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 180 J = 1, K + DO 170 I = 1, LASTC + C( I, J ) = C( I, J ) - WORK( I, J ) + 170 CONTINUE + 180 CONTINUE +* + END IF +* + ELSE +* +* Let V = ( V1 V2 ) (V2: last K columns) +* where V2 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) +* (stored in WORK) +* +* W := C2**T +* + DO 190 J = 1, K + CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, + $ WORK( 1, J ), 1 ) + 190 CONTINUE +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1**T * V1**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**T * W**T +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - V1**T * W**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W**T +* + DO 210 J = 1, K + DO 200 I = 1, LASTC + C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) + 200 CONTINUE + 210 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) +* +* W := C2 +* + DO 220 J = 1, K + CALL DCOPY( LASTC, C( 1, LASTV-K+J ), 1, + $ WORK( 1, J ), 1 ) + 220 CONTINUE +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1 * V1**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - W * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, + $ ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 240 J = 1, K + DO 230 I = 1, LASTC + C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) + 230 CONTINUE + 240 CONTINUE +* + END IF +* + END IF + END IF +* + RETURN +* +* End of DLARFB +* + END + SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION ALPHA, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* Purpose +* ======= +* +* DLARFG generates a real elementary reflector H of order n, such +* that +* +* H * ( alpha ) = ( beta ), H**T * H = I. +* ( x ) ( 0 ) +* +* where alpha and beta are scalars, and x is an (n-1)-element real +* vector. H is represented in the form +* +* H = I - tau * ( 1 ) * ( 1 v**T ) , +* ( v ) +* +* where tau is a real scalar and v is a real (n-1)-element +* vector. +* +* If the elements of x are all zero, then tau = 0 and H is taken to be +* the unit matrix. +* +* Otherwise 1 <= tau <= 2. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the elementary reflector. +* +* ALPHA (input/output) DOUBLE PRECISION +* On entry, the value alpha. +* On exit, it is overwritten with the value beta. +* +* X (input/output) DOUBLE PRECISION array, dimension +* (1+(N-2)*abs(INCX)) +* On entry, the vector x. +* On exit, it is overwritten with the vector v. +* +* INCX (input) INTEGER +* The increment between elements of X. INCX > 0. +* +* TAU (output) DOUBLE PRECISION +* The value tau. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER J, KNT + DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 + EXTERNAL DLAMCH, DLAPY2, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN +* .. +* .. External Subroutines .. + EXTERNAL DSCAL +* .. +* .. Executable Statements .. +* + IF( N.LE.1 ) THEN + TAU = ZERO + RETURN + END IF +* + XNORM = DNRM2( N-1, X, INCX ) +* + IF( XNORM.EQ.ZERO ) THEN +* +* H = I +* + TAU = ZERO + ELSE +* +* general case +* + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) + KNT = 0 + IF( ABS( BETA ).LT.SAFMIN ) THEN +* +* XNORM, BETA may be inaccurate; scale X and recompute them +* + RSAFMN = ONE / SAFMIN + 10 CONTINUE + KNT = KNT + 1 + CALL DSCAL( N-1, RSAFMN, X, INCX ) + BETA = BETA*RSAFMN + ALPHA = ALPHA*RSAFMN + IF( ABS( BETA ).LT.SAFMIN ) + $ GO TO 10 +* +* New BETA is at most 1, at least SAFMIN +* + XNORM = DNRM2( N-1, X, INCX ) + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + END IF + TAU = ( BETA-ALPHA ) / BETA + CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) +* +* If ALPHA is subnormal, it may lose relative accuracy +* + DO 20 J = 1, KNT + BETA = BETA*SAFMIN + 20 CONTINUE + ALPHA = BETA + END IF +* + RETURN +* +* End of DLARFG +* + END + SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* Purpose +* ======= +* +* DLARFT forms the triangular factor T of a real block reflector H +* of order n, which is defined as a product of k elementary reflectors. +* +* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; +* +* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. +* +* If STOREV = 'C', the vector which defines the elementary reflector +* H(i) is stored in the i-th column of the array V, and +* +* H = I - V * T * V**T +* +* If STOREV = 'R', the vector which defines the elementary reflector +* H(i) is stored in the i-th row of the array V, and +* +* H = I - V**T * T * V +* +* Arguments +* ========= +* +* DIRECT (input) CHARACTER*1 +* Specifies the order in which the elementary reflectors are +* multiplied to form the block reflector: +* = 'F': H = H(1) H(2) . . . H(k) (Forward) +* = 'B': H = H(k) . . . H(2) H(1) (Backward) +* +* STOREV (input) CHARACTER*1 +* Specifies how the vectors which define the elementary +* reflectors are stored (see also Further Details): +* = 'C': columnwise +* = 'R': rowwise +* +* N (input) INTEGER +* The order of the block reflector H. N >= 0. +* +* K (input) INTEGER +* The order of the triangular factor T (= the number of +* elementary reflectors). K >= 1. +* +* V (input/output) DOUBLE PRECISION array, dimension +* (LDV,K) if STOREV = 'C' +* (LDV,N) if STOREV = 'R' +* The matrix V. See further details. +* +* LDV (input) INTEGER +* The leading dimension of the array V. +* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i). +* +* T (output) DOUBLE PRECISION array, dimension (LDT,K) +* The k by k triangular factor T of the block reflector. +* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is +* lower triangular. The rest of the array is not used. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= K. +* +* Further Details +* =============== +* +* The shape of the matrix V and the storage of the vectors which define +* the H(i) is best illustrated by the following example with n = 5 and +* k = 3. The elements equal to 1 are not stored; the corresponding +* array elements are modified but restored on exit. The rest of the +* array is not used. +* +* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +* +* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +* ( v1 1 ) ( 1 v2 v2 v2 ) +* ( v1 v2 1 ) ( 1 v3 v3 ) +* ( v1 v2 v3 ) +* ( v1 v2 v3 ) +* +* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +* +* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +* ( v1 v2 v3 ) ( v2 v2 v2 1 ) +* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +* ( 1 v3 ) +* ( 1 ) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, PREVLASTV, LASTV + DOUBLE PRECISION VII +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DTRMV +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( LSAME( DIRECT, 'F' ) ) THEN + PREVLASTV = N + DO 20 I = 1, K + PREVLASTV = MAX( I, PREVLASTV ) + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 10 J = 1, I + T( J, I ) = ZERO + 10 CONTINUE + ELSE +* +* general case +* + VII = V( I, I ) + V( I, I ) = ONE + IF( LSAME( STOREV, 'C' ) ) THEN +! Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) +* + CALL DGEMV( 'Transpose', J-I+1, I-1, -TAU( I ), + $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, + $ T( 1, I ), 1 ) + ELSE +! Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T +* + CALL DGEMV( 'No transpose', I-1, J-I+1, -TAU( I ), + $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, + $ T( 1, I ), 1 ) + END IF + V( I, I ) = VII +* +* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) +* + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, + $ LDT, T( 1, I ), 1 ) + T( I, I ) = TAU( I ) + IF( I.GT.1 ) THEN + PREVLASTV = MAX( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + 20 CONTINUE + ELSE + PREVLASTV = 1 + DO 40 I = K, 1, -1 + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 30 J = I, K + T( J, I ) = ZERO + 30 CONTINUE + ELSE +* +* general case +* + IF( I.LT.K ) THEN + IF( LSAME( STOREV, 'C' ) ) THEN + VII = V( N-K+I, I ) + V( N-K+I, I ) = ONE +! Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) := +* - tau(i) * V(j:n-k+i,i+1:k)**T * +* V(j:n-k+i,i) +* + CALL DGEMV( 'Transpose', N-K+I-J+1, K-I, -TAU( I ), + $ V( J, I+1 ), LDV, V( J, I ), 1, ZERO, + $ T( I+1, I ), 1 ) + V( N-K+I, I ) = VII + ELSE + VII = V( I, N-K+I ) + V( I, N-K+I ) = ONE +! Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) := +* - tau(i) * V(i+1:k,j:n-k+i) * +* V(i,j:n-k+i)**T +* + CALL DGEMV( 'No transpose', K-I, N-K+I-J+1, + $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, + $ ZERO, T( I+1, I ), 1 ) + V( I, N-K+I ) = VII + END IF +* +* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) +* + CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, + $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + IF( I.GT.1 ) THEN + PREVLASTV = MIN( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + T( I, I ) = TAU( I ) + END IF + 40 CONTINUE + END IF + RETURN +* +* End of DLARFT +* + END + SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, K1, K2, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DLASWP performs a series of row interchanges on the matrix A. +* One row interchange is initiated for each of rows K1 through K2 of A. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The number of columns of the matrix A. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the matrix of column dimension N to which the row +* interchanges will be applied. +* On exit, the permuted matrix. +* +* LDA (input) INTEGER +* The leading dimension of the array A. +* +* K1 (input) INTEGER +* The first element of IPIV for which a row interchange will +* be done. +* +* K2 (input) INTEGER +* The last element of IPIV for which a row interchange will +* be done. +* +* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) +* The vector of pivot indices. Only the elements in positions +* K1 through K2 of IPIV are accessed. +* IPIV(K) = L implies rows K and L are to be interchanged. +* +* INCX (input) INTEGER +* The increment between successive values of IPIV. If IPIV +* is negative, the pivots are applied in reverse order. +* +* Further Details +* =============== +* +* Modified by +* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 + DOUBLE PRECISION TEMP +* .. +* .. Executable Statements .. +* +* Interchange row I with row IPIV(I) for each of rows K1 through K2. +* + IF( INCX.GT.0 ) THEN + IX0 = K1 + I1 = K1 + I2 = K2 + INC = 1 + ELSE IF( INCX.LT.0 ) THEN + IX0 = 1 + ( 1-K2 )*INCX + I1 = K2 + I2 = K1 + INC = -1 + ELSE + RETURN + END IF +* + N32 = ( N / 32 )*32 + IF( N32.NE.0 ) THEN + DO 30 J = 1, N32, 32 + IX = IX0 + DO 20 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 10 K = J, J + 31 + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 10 CONTINUE + END IF + IX = IX + INCX + 20 CONTINUE + 30 CONTINUE + END IF + IF( N32.NE.N ) THEN + N32 = N32 + 1 + IX = IX0 + DO 50 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 40 K = N32, N + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 40 CONTINUE + END IF + IX = IX + INCX + 50 CONTINUE + END IF +* + RETURN +* +* End of DLASWP +* + END + SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORM2R overwrites the general real m by n matrix C with +* +* Q * C if SIDE = 'L' and TRANS = 'N', or +* +* Q**T* C if SIDE = 'L' and TRANS = 'T', or +* +* C * Q if SIDE = 'R' and TRANS = 'N', or +* +* C * Q**T if SIDE = 'R' and TRANS = 'T', +* +* where Q is a real orthogonal matrix defined as the product of k +* elementary reflectors +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n +* if SIDE = 'R'. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply Q or Q**T from the Left +* = 'R': apply Q or Q**T from the Right +* +* TRANS (input) CHARACTER*1 +* = 'N': apply Q (No transpose) +* = 'T': apply Q**T (Transpose) +* +* M (input) INTEGER +* The number of rows of the matrix C. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix C. N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines +* the matrix Q. +* If SIDE = 'L', M >= K >= 0; +* if SIDE = 'R', N >= K >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,K) +* The i-th column must contain the vector which defines the +* elementary reflector H(i), for i = 1,2,...,k, as returned by +* DGEQRF in the first k columns of its array argument A. +* A is modified by the routine but restored on exit. +* +* LDA (input) INTEGER +* The leading dimension of the array A. +* If SIDE = 'L', LDA >= max(1,M); +* if SIDE = 'R', LDA >= max(1,N). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DGEQRF. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m by n matrix C. +* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension +* (N) if SIDE = 'L', +* (M) if SIDE = 'R' +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + DOUBLE PRECISION AII +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORM2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) + $ THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), + $ LDC, WORK ) + A( I, I ) = AII + 10 CONTINUE + RETURN +* +* End of DORM2R +* + END + SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORMQR overwrites the general real M-by-N matrix C with +* +* SIDE = 'L' SIDE = 'R' +* TRANS = 'N': Q * C C * Q +* TRANS = 'T': Q**T * C C * Q**T +* +* where Q is a real orthogonal matrix defined as the product of k +* elementary reflectors +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N +* if SIDE = 'R'. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply Q or Q**T from the Left; +* = 'R': apply Q or Q**T from the Right. +* +* TRANS (input) CHARACTER*1 +* = 'N': No transpose, apply Q; +* = 'T': Transpose, apply Q**T. +* +* M (input) INTEGER +* The number of rows of the matrix C. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix C. N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines +* the matrix Q. +* If SIDE = 'L', M >= K >= 0; +* if SIDE = 'R', N >= K >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,K) +* The i-th column must contain the vector which defines the +* elementary reflector H(i), for i = 1,2,...,k, as returned by +* DGEQRF in the first k columns of its array argument A. +* A is modified by the routine but restored on exit. +* +* LDA (input) INTEGER +* The leading dimension of the array A. +* If SIDE = 'L', LDA >= max(1,M); +* if SIDE = 'R', LDA >= max(1,N). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DGEQRF. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the M-by-N matrix C. +* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension +* (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. +* If SIDE = 'L', LWORK >= max(1,N); +* if SIDE = 'R', LWORK >= max(1,M). +* For optimum performance LWORK >= N*NB if SIDE = 'L', and +* LWORK >= M*NB if SIDE = 'R', where NB is the optimal +* blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + DOUBLE PRECISION T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. NB may be at most NBMAX, where NBMAX +* is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), + $ LDA, TAU( I ), T, LDT ) + IF( LEFT ) THEN +* +* H or H**T is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H or H**T is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H or H**T +* + CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, + $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, + $ WORK, LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMQR +* + END + DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* -- LAPACK auxiliary routine (version 3.3.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* Based on LAPACK DLAMCH but with Fortran 95 query functions +* See: http://www.cs.utk.edu/~luszczek/lapack/lamch.html +* and +* http://www.netlib.org/lapack-dev/lapack-coding/program-style.html#id2537289 +* July 2010 +* +* .. Scalar Arguments .. + CHARACTER CMACH +* .. +* +* Purpose +* ======= +* +* DLAMCH determines double precision machine parameters. +* +* Arguments +* ========= +* +* CMACH (input) CHARACTER*1 +* Specifies the value to be returned by DLAMCH: +* = 'E' or 'e', DLAMCH := eps +* = 'S' or 's , DLAMCH := sfmin +* = 'B' or 'b', DLAMCH := base +* = 'P' or 'p', DLAMCH := eps*base +* = 'N' or 'n', DLAMCH := t +* = 'R' or 'r', DLAMCH := rnd +* = 'M' or 'm', DLAMCH := emin +* = 'U' or 'u', DLAMCH := rmin +* = 'L' or 'l', DLAMCH := emax +* = 'O' or 'o', DLAMCH := rmax +* +* where +* +* eps = relative machine precision +* sfmin = safe minimum, such that 1/sfmin does not overflow +* base = base of the machine +* prec = eps*base +* t = number of (base) digits in the mantissa +* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise +* emin = minimum exponent before (gradual) underflow +* rmin = underflow threshold - base**(emin-1) +* emax = largest exponent before overflow +* rmax = overflow threshold - (base**emax)*(1-eps) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, + $ MINEXPONENT, RADIX, TINY +* .. +* .. Executable Statements .. +* +* +* Assume rounding, not chopping. Always. +* + RND = ONE +* + IF( ONE.EQ.RND ) THEN + EPS = EPSILON(ZERO) * 0.5 + ELSE + EPS = EPSILON(ZERO) + END IF +* + IF( LSAME( CMACH, 'E' ) ) THEN + RMACH = EPS + ELSE IF( LSAME( CMACH, 'S' ) ) THEN + SFMIN = TINY(ZERO) + SMALL = ONE / HUGE(ZERO) + IF( SMALL.GE.SFMIN ) THEN +* +* Use SMALL plus a bit, to avoid the possibility of rounding +* causing overflow when computing 1/sfmin. +* + SFMIN = SMALL*( ONE+EPS ) + END IF + RMACH = SFMIN + ELSE IF( LSAME( CMACH, 'B' ) ) THEN + RMACH = RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'P' ) ) THEN + RMACH = EPS * RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'N' ) ) THEN + RMACH = DIGITS(ZERO) + ELSE IF( LSAME( CMACH, 'R' ) ) THEN + RMACH = RND + ELSE IF( LSAME( CMACH, 'M' ) ) THEN + RMACH = MINEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'U' ) ) THEN + RMACH = tiny(zero) + ELSE IF( LSAME( CMACH, 'L' ) ) THEN + RMACH = MAXEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'O' ) ) THEN + RMACH = HUGE(ZERO) + ELSE + RMACH = ZERO + END IF +* + DLAMCH = RMACH + RETURN +* +* End of DLAMCH +* + END +************************************************************************ +* + INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER ISPEC + REAL ONE, ZERO +* .. +* +* Purpose +* ======= +* +* IEEECK is called from the ILAENV to verify that Infinity and +* possibly NaN arithmetic is safe (i.e. will not trap). +* +* Arguments +* ========= +* +* ISPEC (input) INTEGER +* Specifies whether to test just for inifinity arithmetic +* or whether to test for infinity and NaN arithmetic. +* = 0: Verify infinity arithmetic only. +* = 1: Verify infinity and NaN arithmetic. +* +* ZERO (input) REAL +* Must contain the value 0.0 +* This is passed to prevent the compiler from optimizing +* away this code. +* +* ONE (input) REAL +* Must contain the value 1.0 +* This is passed to prevent the compiler from optimizing +* away this code. +* +* RETURN VALUE: INTEGER +* = 0: Arithmetic failed to produce the correct answers +* = 1: Arithmetic produced the correct answers +* +* ===================================================================== +* +* .. Local Scalars .. + REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, + $ NEGZRO, NEWZRO, POSINF +* .. +* .. Executable Statements .. + IEEECK = 1 +* + POSINF = ONE / ZERO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = -ONE / ZERO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGZRO = ONE / ( NEGINF+ONE ) + IF( NEGZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = ONE / NEGZRO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEWZRO = NEGZRO + ZERO + IF( NEWZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = ONE / NEWZRO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = NEGINF*POSINF + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = POSINF*POSINF + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* +* +* +* +* Return if we were only asked to check infinity arithmetic +* + IF( ISPEC.EQ.0 ) + $ RETURN +* + NAN1 = POSINF + NEGINF +* + NAN2 = POSINF / NEGINF +* + NAN3 = POSINF / POSINF +* + NAN4 = POSINF*ZERO +* + NAN5 = NEGINF*NEGZRO +* + NAN6 = NAN5*ZERO +* + IF( NAN1.EQ.NAN1 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN2.EQ.NAN2 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN3.EQ.NAN3 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN4.EQ.NAN4 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN5.EQ.NAN5 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN6.EQ.NAN6 ) THEN + IEEECK = 0 + RETURN + END IF +* + RETURN + END + INTEGER FUNCTION ILADLC( M, N, A, LDA ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.2.2) -- +* +* -- June 2010 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* ILADLC scans A for its last non-zero column. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. +* +* N (input) INTEGER +* The number of columns of the matrix A. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The m by n matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( N.EQ.0 ) THEN + ILADLC = N + ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILADLC = N + ELSE +* Now scan each column from the end, returning with the first +* non-zero. + DO ILADLC = N, 1, -1 + DO I = 1, M + IF( A(I, ILADLC).NE.ZERO ) RETURN + END DO + END DO + END IF + RETURN + END + INTEGER FUNCTION ILADLR( M, N, A, LDA ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* ILADLR scans A for its last non-zero row. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. +* +* N (input) INTEGER +* The number of columns of the matrix A. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The m by n matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( M.EQ.0 ) THEN + ILADLR = M + ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILADLR = M + ELSE +* Scan up each column tracking the last zero row seen. + ILADLR = 0 + DO J = 1, N + I=M + DO WHILE ((A(I,J).NE.ZERO).AND.(I.GE.1)) + I=I-1 + ENDDO + ILADLR = MAX( ILADLR, I ) + END DO + END IF + RETURN + END + INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* -- LAPACK auxiliary routine (version 3.2.1) -- +* +* -- April 2009 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* Purpose +* ======= +* +* ILAENV is called from the LAPACK routines to choose problem-dependent +* parameters for the local environment. See ISPEC for a description of +* the parameters. +* +* ILAENV returns an INTEGER +* if ILAENV >= 0: ILAENV returns the value of the parameter specified +* by ISPEC +* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal +* value. +* +* This version provides a set of parameters which should give good, +* but not optimal, performance on many of the currently available +* computers. Users are encouraged to modify this subroutine to set +* the tuning parameters for their particular machine using the option +* and problem size information in the arguments. +* +* This routine will not function correctly if it is converted to all +* lower case. Converting it to all upper case is allowed. +* +* Arguments +* ========= +* +* ISPEC (input) INTEGER +* Specifies the parameter to be returned as the value of +* ILAENV. +* = 1: the optimal blocksize; if this value is 1, an unblocked +* algorithm will give the best performance. +* = 2: the minimum block size for which the block routine +* should be used; if the usable block size is less than +* this value, an unblocked routine should be used. +* = 3: the crossover point (in a block routine, for N less +* than this value, an unblocked routine should be used) +* = 4: the number of shifts, used in the nonsymmetric +* eigenvalue routines (DEPRECATED) +* = 5: the minimum column dimension for blocking to be used; +* rectangular blocks must have dimension at least k by m, +* where k is given by ILAENV(2,...) and m by ILAENV(5,...) +* = 6: the crossover point for the SVD (when reducing an m by n +* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds +* this value, a QR factorization is used first to reduce +* the matrix to a triangular form.) +* = 7: the number of processors +* = 8: the crossover point for the multishift QR method +* for nonsymmetric eigenvalue problems (DEPRECATED) +* = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* =10: ieee NaN arithmetic can be trusted not to trap +* =11: infinity arithmetic can be trusted not to trap +* 12 <= ISPEC <= 16: +* xHSEQR or one of its subroutines, +* see IPARMQ for detailed explanation +* +* NAME (input) CHARACTER*(*) +* The name of the calling subroutine, in either upper case or +* lower case. +* +* OPTS (input) CHARACTER*(*) +* The character options to the subroutine NAME, concatenated +* into a single character string. For example, UPLO = 'U', +* TRANS = 'T', and DIAG = 'N' for a triangular routine would +* be specified as OPTS = 'UTN'. +* +* N1 (input) INTEGER +* N2 (input) INTEGER +* N3 (input) INTEGER +* N4 (input) INTEGER +* Problem dimensions for the subroutine NAME; these may not all +* be required. +* +* Further Details +* =============== +* +* The following conventions have been used when calling ILAENV from the +* LAPACK routines: +* 1) OPTS is a concatenation of all of the character options to +* subroutine NAME, in the same order that they appear in the +* argument list for NAME, even if they are not used in determining +* the value of the parameter specified by ISPEC. +* 2) The problem dimensions N1, N2, N3, N4 are specified in the order +* that they appear in the argument list for NAME. N1 is used +* first, N2 second, and so on, and unused problem dimensions are +* passed a value of -1. +* 3) The parameter value returned by ILAENV is checked for validity in +* the calling subroutine. For example, ILAENV is used to retrieve +* the optimal blocksize for STRTRI as follows: +* +* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) +* IF( NB.LE.1 ) NB = MAX( 1, N ) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IC, IZ, NB, NBMIN, NX + LOGICAL CNAME, SNAME + CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 +* .. +* .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, INT, MIN, REAL +* .. +* .. External Functions .. + INTEGER IEEECK, IPARMQ + EXTERNAL IEEECK, IPARMQ +* .. +* .. Executable Statements .. +* + GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, + $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC +* +* Invalid value for ISPEC +* + ILAENV = -1 + RETURN +* + 10 CONTINUE +* +* Convert NAME to upper case if the first character is lower case. +* + ILAENV = 1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 20 CONTINUE + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + 30 CONTINUE + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 40 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 40 CONTINUE + END IF + END IF +* + C1 = SUBNAM( 1: 1 ) + SNAME = C1.EQ.'S' .OR. C1.EQ.'D' + CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' + IF( .NOT.( CNAME .OR. SNAME ) ) + $ RETURN + C2 = SUBNAM( 2: 3 ) + C3 = SUBNAM( 4: 6 ) + C4 = C3( 2: 3 ) +* + GO TO ( 50, 60, 70 )ISPEC +* + 50 CONTINUE +* +* ISPEC = 1: block size +* +* In these examples, separate code is provided for setting NB for +* real and complex. We assume that NB will take the same value in +* single or double precision. +* + NB = 1 +* + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'PO' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRF' ) THEN + NB = 64 + ELSE IF( C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( C2.EQ.'GB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'PB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'TR' ) THEN + IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'LA' ) THEN + IF( C3.EQ.'UUM' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN + IF( C3.EQ.'EBZ' ) THEN + NB = 1 + END IF + END IF + ILAENV = NB + RETURN +* + 60 CONTINUE +* +* ISPEC = 2: minimum block size +* + NBMIN = 2 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NBMIN = 8 + ELSE + NBMIN = 8 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + END IF + ILAENV = NBMIN + RETURN +* + 70 CONTINUE +* +* ISPEC = 3: crossover point +* + NX = 0 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + END IF + ILAENV = NX + RETURN +* + 80 CONTINUE +* +* ISPEC = 4: number of shifts (used by xHSEQR) +* + ILAENV = 6 + RETURN +* + 90 CONTINUE +* +* ISPEC = 5: minimum column dimension (not used) +* + ILAENV = 2 + RETURN +* + 100 CONTINUE +* +* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) +* + ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) + RETURN +* + 110 CONTINUE +* +* ISPEC = 7: number of processors (not used) +* + ILAENV = 1 + RETURN +* + 120 CONTINUE +* +* ISPEC = 8: crossover point for multishift (used by xHSEQR) +* + ILAENV = 50 + RETURN +* + 130 CONTINUE +* +* ISPEC = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* + ILAENV = 25 + RETURN +* + 140 CONTINUE +* +* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 1, 0.0, 1.0 ) + END IF + RETURN +* + 150 CONTINUE +* +* ISPEC = 11: infinity arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 0, 0.0, 1.0 ) + END IF + RETURN +* + 160 CONTINUE +* +* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. +* + ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + RETURN +* +* End of ILAENV +* + END + INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG +* Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, ISPEC, LWORK, N + CHARACTER NAME*( * ), OPTS*( * ) +* +* Purpose +* ======= +* +* This program sets problem and machine dependent parameters +* useful for xHSEQR and its subroutines. It is called whenever +* ILAENV is called with 12 <= ISPEC <= 16 +* +* Arguments +* ========= +* +* ISPEC (input) integer scalar +* ISPEC specifies which tunable parameter IPARMQ should +* return. +* +* ISPEC=12: (INMIN) Matrices of order nmin or less +* are sent directly to xLAHQR, the implicit +* double shift QR algorithm. NMIN must be +* at least 11. +* +* ISPEC=13: (INWIN) Size of the deflation window. +* This is best set greater than or equal to +* the number of simultaneous shifts NS. +* Larger matrices benefit from larger deflation +* windows. +* +* ISPEC=14: (INIBL) Determines when to stop nibbling and +* invest in an (expensive) multi-shift QR sweep. +* If the aggressive early deflation subroutine +* finds LD converged eigenvalues from an order +* NW deflation window and LD.GT.(NW*NIBBLE)/100, +* then the next QR sweep is skipped and early +* deflation is applied immediately to the +* remaining active diagonal block. Setting +* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a +* multi-shift QR sweep whenever early deflation +* finds a converged eigenvalue. Setting +* IPARMQ(ISPEC=14) greater than or equal to 100 +* prevents TTQRE from skipping a multi-shift +* QR sweep. +* +* ISPEC=15: (NSHFTS) The number of simultaneous shifts in +* a multi-shift QR iteration. +* +* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the +* following meanings. +* 0: During the multi-shift QR sweep, +* xLAQR5 does not accumulate reflections and +* does not use matrix-matrix multiply to +* update the far-from-diagonal matrix +* entries. +* 1: During the multi-shift QR sweep, +* xLAQR5 and/or xLAQRaccumulates reflections +* and uses +* matrix-matrix multiply to update the +* far-from-diagonal matrix entries. +* 2: During the multi-shift QR sweep. +* xLAQR5 accumulates reflections and takes +* advantage of 2-by-2 block structure during +* matrix-matrix multiplies. +* (If xTRMM is slower than xGEMM, then +* IPARMQ(ISPEC=16)=1 may be more efficient than +* IPARMQ(ISPEC=16)=2 despite the greater level of +* arithmetic work implied by the latter choice.) +* +* NAME (input) character string +* Name of the calling subroutine +* +* OPTS (input) character string +* This is a concatenation of the string arguments to +* TTQRE. +* +* N (input) integer scalar +* N is the order of the Hessenberg matrix H. +* +* ILO (input) INTEGER +* IHI (input) INTEGER +* It is assumed that H is already upper triangular +* in rows and columns 1:ILO-1 and IHI+1:N. +* +* LWORK (input) integer scalar +* The amount of workspace available. +* +* Further Details +* =============== +* +* Little is known about how best to choose these parameters. +* It is possible to use different values of the parameters +* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. +* +* It is probably best to choose different parameters for +* different matrices and different parameters at different +* times during the iteration, but this has not been +* implemented --- yet. +* +* +* The best choices of most of the parameters depend +* in an ill-understood way on the relative execution +* rate of xLAQR3 and xLAQR5 and on the nature of each +* particular eigenvalue problem. Experiment may be the +* only practical way to determine which choices are most +* effective. +* +* Following is a list of default values supplied by IPARMQ. +* These defaults may be adjusted in order to attain better +* performance in any particular computational environment. +* +* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. +* Default: 75. (Must be at least 11.) +* +* IPARMQ(ISPEC=13) Recommended deflation window size. +* This depends on ILO, IHI and NS, the +* number of simultaneous shifts returned +* by IPARMQ(ISPEC=15). The default for +* (IHI-ILO+1).LE.500 is NS. The default +* for (IHI-ILO+1).GT.500 is 3*NS/2. +* +* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. +* +* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. +* a multi-shift QR iteration. +* +* If IHI-ILO+1 is ... +* +* greater than ...but less ... the +* or equal to ... than default is +* +* 0 30 NS = 2+ +* 30 60 NS = 4+ +* 60 150 NS = 10 +* 150 590 NS = ** +* 590 3000 NS = 64 +* 3000 6000 NS = 128 +* 6000 infinity NS = 256 +* +* (+) By default matrices of this order are +* passed to the implicit double shift routine +* xLAHQR. See IPARMQ(ISPEC=12) above. These +* values of NS are used only in case of a rare +* xLAHQR failure. +* +* (**) The asterisks (**) indicate an ad-hoc +* function increasing from 10 to 64. +* +* IPARMQ(ISPEC=16) Select structured matrix multiply. +* (See ISPEC=16 above for details.) +* Default: 3. +* +* ================================================================ +* .. Parameters .. + INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 + PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, + $ ISHFTS = 15, IACC22 = 16 ) + INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP + PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, + $ NIBBLE = 14, KNWSWP = 500 ) + REAL TWO + PARAMETER ( TWO = 2.0 ) +* .. +* .. Local Scalars .. + INTEGER NH, NS +* .. +* .. Intrinsic Functions .. + INTRINSIC LOG, MAX, MOD, NINT, REAL +* .. +* .. Executable Statements .. + IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. + $ ( ISPEC.EQ.IACC22 ) ) THEN +* +* ==== Set the number simultaneous shifts ==== +* + NH = IHI - ILO + 1 + NS = 2 + IF( NH.GE.30 ) + $ NS = 4 + IF( NH.GE.60 ) + $ NS = 10 + IF( NH.GE.150 ) + $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) + IF( NH.GE.590 ) + $ NS = 64 + IF( NH.GE.3000 ) + $ NS = 128 + IF( NH.GE.6000 ) + $ NS = 256 + NS = MAX( 2, NS-MOD( NS, 2 ) ) + END IF +* + IF( ISPEC.EQ.INMIN ) THEN +* +* +* ===== Matrices of order smaller than NMIN get sent +* . to xLAHQR, the classic double shift algorithm. +* . This must be at least 11. ==== +* + IPARMQ = NMIN +* + ELSE IF( ISPEC.EQ.INIBL ) THEN +* +* ==== INIBL: skip a multi-shift qr iteration and +* . whenever aggressive early deflation finds +* . at least (NIBBLE*(window size)/100) deflations. ==== +* + IPARMQ = NIBBLE +* + ELSE IF( ISPEC.EQ.ISHFTS ) THEN +* +* ==== NSHFTS: The number of simultaneous shifts ===== +* + IPARMQ = NS +* + ELSE IF( ISPEC.EQ.INWIN ) THEN +* +* ==== NW: deflation window size. ==== +* + IF( NH.LE.KNWSWP ) THEN + IPARMQ = NS + ELSE + IPARMQ = 3*NS / 2 + END IF +* + ELSE IF( ISPEC.EQ.IACC22 ) THEN +* +* ==== IACC22: Whether to accumulate reflections +* . before updating the far-from-diagonal elements +* . and whether to use 2-by-2 block structure while +* . doing it. A small amount of work could be saved +* . by making this choice dependent also upon the +* . NH=IHI-ILO+1. +* + IPARMQ = 0 + IF( NS.GE.KACMIN ) + $ IPARMQ = 1 + IF( NS.GE.K22MIN ) + $ IPARMQ = 2 +* + ELSE +* ===== invalid value of ispec ===== + IPARMQ = -1 +* + END IF +* +* ==== End of IPARMQ ==== +* + END + diff --git a/src/sample_input2d.dat b/src/sample_input2d.dat new file mode 100644 index 0000000..1ebeed6 --- /dev/null +++ b/src/sample_input2d.dat @@ -0,0 +1,188 @@ +2,43,101,1 +-0.737779900597,-0.675041345605 +-0.737779900597,0.587602108436 +0.524863553445,-0.675041345605 +0.524863553445,0.587602108436 +-0.663506756241,0.166253571025 +-0.584282068929,-0.394609706728 +-0.584282068929,0.446685209901 +-0.584282068929,0.586901029339 +-0.425832694304,-0.534825526166 +-0.425832694304,-0.464717616447 +-0.425832694304,-0.184285977571 +-0.425832694304,-0.0440701581327 +-0.425832694304,0.0961456613055 +-0.425832694304,0.236361480744 +-0.425832694304,0.51679311962 +-0.108933945055,-0.675041345605 +-0.108933945055,-0.534825526166 +-0.108933945055,-0.464717616447 +-0.108933945055,-0.394609706728 +-0.108933945055,-0.25439388729 +-0.108933945055,-0.184285977571 +-0.108933945055,-0.114178067852 +-0.108933945055,-0.0440701581327 +-0.108933945055,0.0961456613055 +-0.108933945055,0.166253571025 +-0.108933945055,0.236361480744 +-0.108933945055,0.376577300182 +-0.108933945055,0.51679311962 +-0.108933945055,0.587602108436 +0.524863553445,-0.534825526166 +0.524863553445,-0.464717616447 +0.524863553445,-0.394609706728 +0.524863553445,-0.25439388729 +0.524863553445,-0.184285977571 +0.524863553445,-0.114178067852 +0.524863553445,-0.0440701581327 +0.524863553445,0.0961456613055 +0.524863553445,0.166253571025 +0.524863553445,0.236361480744 +0.524863553445,0.376577300182 +0.524863553445,0.446685209901 +0.524863553445,0.51679311962 +0.524863553445,0.586901029339 +296835782027 +736030395045 +1.06918217819E+016 +3.20566930178E+016 +73374496803300 +189039708822000 +273719385634000 +326069037783000 +675040018268000 +756967336463000 +914266006037000 +1.0830311159E+015 +1218388638980000 +1326756634210000 +1463454444460000 +2.5144413074E+015 +2.77933373432E+015 +2836545644680000 +3155262430390000 +3451182362430000 +3715001247780000 +3896447879110000 +4.11531577031E+015 +4745519778190000 +4840384897050000 +5228331120200000 +5481722046370000 +6250890553900000 +7367804014150000 +1.16388102101E+016 +1.11174656608E+016 +1.25221884669E+016 +1.49468718462E+016 +1.468022513E+016 +1.54642127154E+016 +1.65072763423E+016 +2.08248675151E+016 +1.86574133761E+016 +2.01386128979E+016 +2.38441779462E+016 +2.52856646169E+016 +2.56482815535E+016 +2.78334409382E+016 +-0.737779900597,-0.534825526166 +-0.737779900597,-0.464717616447 +-0.737779900597,-0.394609706728 +-0.737779900597,-0.25439388729 +-0.737779900597,-0.184285977571 +-0.737779900597,-0.114178067852 +-0.737779900597,-0.0440701581327 +-0.737779900597,0.0961456613055 +-0.737779900597,0.166253571025 +-0.737779900597,0.236361480744 +-0.737779900597,0.376577300182 +-0.737779900597,0.446685209901 +-0.737779900597,0.51679311962 +-0.737779900597,0.586901029339 +-0.73282835764,-0.675041345605 +-0.73282835764,-0.534825526166 +-0.73282835764,-0.464717616447 +-0.73282835764,-0.394609706728 +-0.73282835764,-0.25439388729 +-0.73282835764,-0.184285977571 +-0.73282835764,-0.114178067852 +-0.73282835764,-0.0440701581327 +-0.73282835764,0.0961456613055 +-0.73282835764,0.166253571025 +-0.73282835764,0.236361480744 +-0.73282835764,0.376577300182 +-0.73282835764,0.446685209901 +-0.73282835764,0.51679311962 +-0.73282835764,0.586901029339 +-0.73282835764,0.587602108436 +-0.722925271725,-0.675041345605 +-0.722925271725,-0.534825526166 +-0.722925271725,-0.464717616447 +-0.722925271725,-0.394609706728 +-0.722925271725,-0.25439388729 +-0.722925271725,-0.184285977571 +-0.722925271725,-0.114178067852 +-0.722925271725,-0.0440701581327 +-0.722925271725,0.0961456613055 +-0.722925271725,0.166253571025 +-0.722925271725,0.236361480744 +-0.722925271725,0.376577300182 +-0.722925271725,0.446685209901 +-0.722925271725,0.51679311962 +-0.722925271725,0.586901029339 +-0.722925271725,0.587602108436 +-0.703119099897,-0.675041345605 +-0.703119099897,-0.534825526166 +-0.703119099897,-0.464717616447 +-0.703119099897,-0.394609706728 +-0.703119099897,-0.25439388729 +-0.703119099897,-0.184285977571 +-0.703119099897,-0.114178067852 +-0.703119099897,-0.0440701581327 +-0.703119099897,0.0961456613055 +-0.703119099897,0.166253571025 +-0.703119099897,0.236361480744 +-0.703119099897,0.376577300182 +-0.703119099897,0.446685209901 +-0.703119099897,0.51679311962 +-0.703119099897,0.586901029339 +-0.703119099897,0.587602108436 +-0.663506756241,-0.675041345605 +-0.663506756241,-0.534825526166 +-0.663506756241,-0.464717616447 +-0.663506756241,-0.394609706728 +-0.663506756241,-0.25439388729 +-0.663506756241,-0.184285977571 +-0.663506756241,-0.114178067852 +-0.663506756241,-0.0440701581327 +-0.663506756241,0.0961456613055 +-0.663506756241,0.236361480744 +-0.663506756241,0.376577300182 +-0.663506756241,0.446685209901 +-0.663506756241,0.51679311962 +-0.663506756241,0.586901029339 +-0.663506756241,0.587602108436 +-0.584282068929,-0.675041345605 +-0.584282068929,-0.534825526166 +-0.584282068929,-0.464717616447 +-0.584282068929,-0.25439388729 +-0.584282068929,-0.184285977571 +-0.584282068929,-0.114178067852 +-0.584282068929,-0.0440701581327 +-0.584282068929,0.0961456613055 +-0.584282068929,0.166253571025 +-0.584282068929,0.236361480744 +-0.584282068929,0.376577300182 +-0.584282068929,0.51679311962 +-0.584282068929,0.587602108436 +-0.425832694304,-0.675041345605 +-0.425832694304,-0.394609706728 +-0.425832694304,-0.25439388729 +-0.425832694304,-0.114178067852 +-0.425832694304,0.166253571025 +-0.425832694304,0.376577300182 +-0.425832694304,0.446685209901 +-0.425832694304,0.586901029339 +-0.425832694304,0.587602108436 +-0.108933945055,0.446685209901 +-0.108933945055,0.586901029339 diff --git a/src/sample_input4d.dat b/src/sample_input4d.dat new file mode 100644 index 0000000..f786eda --- /dev/null +++ b/src/sample_input4d.dat @@ -0,0 +1,1297 @@ +4,432,432,1 +-0.429559544383,-0.141336559823,-0.324322498044,-0.452914378473 +-0.429559544383,-0.141336559823,-0.324322498044,0.346266169217 +-0.429559544383,-0.141336559823,0.474858049646,-0.452914378473 +-0.429559544383,-0.141336559823,0.474858049646,0.346266169217 +0.369621003307,-0.141336559823,-0.324322498044,-0.452914378473 +0.369621003307,-0.141336559823,-0.324322498044,0.346266169217 +0.369621003307,-0.141336559823,0.474858049646,-0.452914378473 +0.369621003307,-0.141336559823,0.474858049646,0.346266169217 +0.369621003307,0.657843987867,-0.324322498044,-0.452914378473 +0.369621003307,0.657843987867,-0.324322498044,0.346266169217 +0.369621003307,0.657843987867,0.474858049646,-0.452914378473 +0.369621003307,0.657843987867,0.474858049646,0.346266169217 +-0.429559544383,-0.141336559823,-0.302384208499,-0.452914378473 +-0.429559544383,-0.141336559823,-0.302384208499,0.21269962571 +-0.429559544383,-0.141336559823,-0.277311877591,-0.452914378473 +-0.429559544383,-0.141336559823,-0.277311877591,-0.364165844582 +-0.429559544383,-0.141336559823,-0.277311877591,-0.275417310691 +-0.429559544383,-0.141336559823,-0.277311877591,0.0795768248736 +-0.429559544383,-0.141336559823,-0.277311877591,0.123951091819 +-0.429559544383,-0.141336559823,-0.277311877591,0.21269962571 +-0.429559544383,-0.141336559823,-0.277311877591,0.345822426547 +-0.429559544383,-0.141336559823,-0.277311877591,0.346266169217 +-0.429559544383,-0.141336559823,-0.227167215775,-0.1866687768 +-0.429559544383,-0.141336559823,-0.227167215775,-0.142294509854 +-0.429559544383,-0.141336559823,-0.227167215775,-0.0979202429087 +-0.429559544383,-0.141336559823,-0.227167215775,-0.0535459759631 +-0.429559544383,-0.141336559823,-0.227167215775,0.0352025579281 +-0.429559544383,-0.141336559823,-0.227167215775,0.0795768248736 +-0.429559544383,-0.141336559823,-0.227167215775,0.123951091819 +-0.429559544383,-0.141336559823,-0.227167215775,0.21269962571 +-0.429559544383,-0.141336559823,-0.227167215775,0.257073892656 +-0.429559544383,-0.141336559823,-0.227167215775,0.301448159602 +-0.429559544383,-0.141336559823,-0.227167215775,0.345822426547 +-0.429559544383,-0.141336559823,-0.227167215775,0.346266169217 +-0.429559544383,-0.141336559823,-0.126877892144,-0.364165844582 +-0.429559544383,-0.141336559823,-0.126877892144,-0.319791577637 +-0.429559544383,-0.141336559823,-0.126877892144,-0.275417310691 +-0.429559544383,-0.141336559823,-0.126877892144,-0.1866687768 +-0.429559544383,-0.141336559823,-0.126877892144,-0.142294509854 +-0.429559544383,-0.141336559823,-0.126877892144,-0.0979202429087 +-0.429559544383,-0.141336559823,-0.126877892144,-0.0535459759631 +-0.429559544383,-0.141336559823,-0.126877892144,0.0352025579281 +-0.429559544383,-0.141336559823,-0.126877892144,0.0795768248736 +-0.429559544383,-0.141336559823,-0.126877892144,0.123951091819 +-0.429559544383,-0.141336559823,-0.126877892144,0.21269962571 +-0.429559544383,-0.141336559823,-0.126877892144,0.257073892656 +-0.429559544383,-0.141336559823,-0.126877892144,0.301448159602 +-0.429559544383,-0.141336559823,-0.126877892144,0.345822426547 +-0.429559544383,-0.141336559823,-0.126877892144,0.346266169217 +-0.429559544383,-0.141336559823,0.0737007551197,-0.452914378473 +-0.429559544383,-0.141336559823,0.0737007551197,-0.364165844582 +-0.429559544383,-0.141336559823,0.0737007551197,-0.319791577637 +-0.429559544383,-0.141336559823,0.0737007551197,-0.275417310691 +-0.429559544383,-0.141336559823,0.0737007551197,-0.1866687768 +-0.429559544383,-0.141336559823,0.0737007551197,-0.142294509854 +-0.429559544383,-0.141336559823,0.0737007551197,-0.0979202429087 +-0.429559544383,-0.141336559823,0.0737007551197,-0.0535459759631 +-0.429559544383,-0.141336559823,0.0737007551197,0.0352025579281 +-0.429559544383,-0.141336559823,0.0737007551197,0.0795768248736 +-0.429559544383,-0.141336559823,0.0737007551197,0.123951091819 +-0.429559544383,-0.141336559823,0.0737007551197,0.21269962571 +-0.429559544383,-0.141336559823,0.0737007551197,0.257073892656 +-0.429559544383,-0.141336559823,0.0737007551197,0.301448159602 +-0.429559544383,-0.141336559823,0.0737007551197,0.345822426547 +-0.429559544383,-0.141336559823,0.0737007551197,0.346266169217 +-0.429559544383,-0.141336559823,0.474858049646,-0.364165844582 +-0.429559544383,-0.141336559823,0.474858049646,-0.319791577637 +-0.429559544383,-0.141336559823,0.474858049646,-0.275417310691 +-0.429559544383,-0.141336559823,0.474858049646,-0.1866687768 +-0.429559544383,-0.141336559823,0.474858049646,-0.142294509854 +-0.429559544383,-0.141336559823,0.474858049646,-0.0979202429087 +-0.429559544383,-0.141336559823,0.474858049646,-0.0535459759631 +-0.429559544383,-0.141336559823,0.474858049646,0.0352025579281 +-0.429559544383,-0.141336559823,0.474858049646,0.0795768248736 +-0.429559544383,-0.141336559823,0.474858049646,0.123951091819 +-0.429559544383,-0.141336559823,0.474858049646,0.21269962571 +-0.429559544383,-0.141336559823,0.474858049646,0.257073892656 +-0.429559544383,-0.141336559823,0.474858049646,0.301448159602 +-0.429559544383,-0.141336559823,0.474858049646,0.345822426547 +-0.269723434845,-0.141336559823,-0.32118845668,0.21269962571 +-0.269723434845,-0.141336559823,-0.314920373953,0.0352025579281 +-0.269723434845,-0.141336559823,-0.314920373953,0.0795768248736 +-0.269723434845,-0.141336559823,-0.314920373953,0.301448159602 +-0.269723434845,-0.141336559823,-0.302384208499,-0.364165844582 +-0.269723434845,-0.141336559823,-0.302384208499,-0.275417310691 +-0.269723434845,-0.141336559823,-0.302384208499,-0.1866687768 +-0.269723434845,-0.141336559823,-0.302384208499,-0.0979202429087 +-0.269723434845,-0.141336559823,-0.302384208499,0.0795768248736 +-0.269723434845,-0.141336559823,-0.302384208499,0.301448159602 +-0.269723434845,-0.141336559823,-0.277311877591,-0.452914378473 +-0.269723434845,-0.141336559823,-0.277311877591,-0.275417310691 +-0.269723434845,-0.141336559823,-0.277311877591,-0.142294509854 +-0.269723434845,-0.141336559823,-0.277311877591,-0.0979202429087 +-0.269723434845,-0.141336559823,-0.277311877591,0.0352025579281 +-0.269723434845,-0.141336559823,-0.277311877591,0.0795768248736 +-0.269723434845,-0.141336559823,-0.277311877591,0.123951091819 +-0.269723434845,-0.141336559823,-0.277311877591,0.21269962571 +-0.269723434845,-0.141336559823,-0.277311877591,0.257073892656 +-0.269723434845,-0.141336559823,-0.277311877591,0.345822426547 +-0.269723434845,-0.141336559823,-0.277311877591,0.346266169217 +-0.269723434845,-0.141336559823,-0.227167215775,-0.452914378473 +-0.269723434845,-0.141336559823,-0.227167215775,-0.364165844582 +-0.269723434845,-0.141336559823,-0.227167215775,-0.319791577637 +-0.269723434845,-0.141336559823,-0.227167215775,-0.275417310691 +-0.269723434845,-0.141336559823,-0.227167215775,-0.0979202429087 +-0.269723434845,-0.141336559823,-0.227167215775,-0.0535459759631 +-0.269723434845,-0.141336559823,-0.227167215775,0.0352025579281 +-0.269723434845,-0.141336559823,-0.227167215775,0.0795768248736 +-0.269723434845,-0.141336559823,-0.227167215775,0.123951091819 +-0.269723434845,-0.141336559823,-0.227167215775,0.21269962571 +-0.269723434845,-0.141336559823,-0.227167215775,0.257073892656 +-0.269723434845,-0.141336559823,-0.227167215775,0.301448159602 +-0.269723434845,-0.141336559823,-0.227167215775,0.345822426547 +-0.269723434845,-0.141336559823,-0.227167215775,0.346266169217 +-0.269723434845,-0.141336559823,-0.126877892144,-0.452914378473 +-0.269723434845,-0.141336559823,-0.126877892144,-0.364165844582 +-0.269723434845,-0.141336559823,-0.126877892144,-0.319791577637 +-0.269723434845,-0.141336559823,-0.126877892144,-0.275417310691 +-0.269723434845,-0.141336559823,-0.126877892144,-0.1866687768 +-0.269723434845,-0.141336559823,-0.126877892144,-0.142294509854 +-0.269723434845,-0.141336559823,-0.126877892144,-0.0979202429087 +-0.269723434845,-0.141336559823,-0.126877892144,-0.0535459759631 +-0.269723434845,-0.141336559823,-0.126877892144,0.0352025579281 +-0.269723434845,-0.141336559823,-0.126877892144,0.0795768248736 +-0.269723434845,-0.141336559823,-0.126877892144,0.123951091819 +-0.269723434845,-0.141336559823,-0.126877892144,0.21269962571 +-0.269723434845,-0.141336559823,-0.126877892144,0.257073892656 +-0.269723434845,-0.141336559823,-0.126877892144,0.301448159602 +-0.269723434845,-0.141336559823,-0.126877892144,0.345822426547 +-0.269723434845,-0.141336559823,-0.126877892144,0.346266169217 +-0.269723434845,-0.141336559823,0.0737007551197,-0.452914378473 +-0.269723434845,-0.141336559823,0.0737007551197,-0.364165844582 +-0.269723434845,-0.141336559823,0.0737007551197,-0.319791577637 +-0.269723434845,-0.141336559823,0.0737007551197,-0.275417310691 +-0.269723434845,-0.141336559823,0.0737007551197,-0.1866687768 +-0.269723434845,-0.141336559823,0.0737007551197,-0.142294509854 +-0.269723434845,-0.141336559823,0.0737007551197,-0.0979202429087 +-0.269723434845,-0.141336559823,0.0737007551197,-0.0535459759631 +-0.269723434845,-0.141336559823,0.0737007551197,0.0352025579281 +-0.269723434845,-0.141336559823,0.0737007551197,0.0795768248736 +-0.269723434845,-0.141336559823,0.0737007551197,0.123951091819 +-0.269723434845,-0.141336559823,0.0737007551197,0.21269962571 +-0.269723434845,-0.141336559823,0.0737007551197,0.257073892656 +-0.269723434845,-0.141336559823,0.0737007551197,0.301448159602 +-0.269723434845,-0.141336559823,0.0737007551197,0.345822426547 +-0.269723434845,-0.141336559823,0.0737007551197,0.346266169217 +-0.269723434845,-0.141336559823,0.474858049646,-0.452914378473 +-0.269723434845,-0.141336559823,0.474858049646,-0.364165844582 +-0.269723434845,-0.141336559823,0.474858049646,-0.319791577637 +-0.269723434845,-0.141336559823,0.474858049646,-0.275417310691 +-0.269723434845,-0.141336559823,0.474858049646,-0.1866687768 +-0.269723434845,-0.141336559823,0.474858049646,-0.142294509854 +-0.269723434845,-0.141336559823,0.474858049646,-0.0979202429087 +-0.269723434845,-0.141336559823,0.474858049646,-0.0535459759631 +-0.269723434845,-0.141336559823,0.474858049646,0.0352025579281 +-0.269723434845,-0.141336559823,0.474858049646,0.0795768248736 +-0.269723434845,-0.141336559823,0.474858049646,0.123951091819 +-0.269723434845,-0.141336559823,0.474858049646,0.21269962571 +-0.269723434845,-0.141336559823,0.474858049646,0.257073892656 +-0.269723434845,-0.141336559823,0.474858049646,0.301448159602 +-0.269723434845,-0.141336559823,0.474858049646,0.345822426547 +-0.269723434845,-0.141336559823,0.474858049646,0.346266169217 +-0.269723434845,0.018499549715,-0.324322498044,-0.452914378473 +-0.269723434845,0.018499549715,-0.314920373953,0.0795768248736 +-0.269723434845,0.018499549715,-0.314920373953,0.301448159602 +-0.269723434845,0.018499549715,-0.314920373953,0.346266169217 +-0.269723434845,0.018499549715,-0.302384208499,-0.452914378473 +-0.269723434845,0.018499549715,-0.302384208499,0.0795768248736 +-0.269723434845,0.018499549715,-0.302384208499,0.21269962571 +-0.269723434845,0.018499549715,-0.302384208499,0.345822426547 +-0.269723434845,0.018499549715,-0.277311877591,-0.452914378473 +-0.269723434845,0.018499549715,-0.277311877591,-0.364165844582 +-0.269723434845,0.018499549715,-0.277311877591,-0.275417310691 +-0.269723434845,0.018499549715,-0.277311877591,-0.0979202429087 +-0.269723434845,0.018499549715,-0.277311877591,0.0795768248736 +-0.269723434845,0.018499549715,-0.277311877591,0.123951091819 +-0.269723434845,0.018499549715,-0.277311877591,0.21269962571 +-0.269723434845,0.018499549715,-0.277311877591,0.301448159602 +-0.269723434845,0.018499549715,-0.277311877591,0.345822426547 +-0.269723434845,0.018499549715,-0.227167215775,-0.452914378473 +-0.269723434845,0.018499549715,-0.227167215775,-0.364165844582 +-0.269723434845,0.018499549715,-0.227167215775,-0.319791577637 +-0.269723434845,0.018499549715,-0.227167215775,-0.275417310691 +-0.269723434845,0.018499549715,-0.227167215775,-0.1866687768 +-0.269723434845,0.018499549715,-0.227167215775,-0.142294509854 +-0.269723434845,0.018499549715,-0.227167215775,-0.0979202429087 +-0.269723434845,0.018499549715,-0.227167215775,-0.0535459759631 +-0.269723434845,0.018499549715,-0.227167215775,0.0352025579281 +-0.269723434845,0.018499549715,-0.227167215775,0.0795768248736 +-0.269723434845,0.018499549715,-0.227167215775,0.257073892656 +-0.269723434845,0.018499549715,-0.227167215775,0.301448159602 +-0.269723434845,0.018499549715,-0.227167215775,0.345822426547 +-0.269723434845,0.018499549715,-0.227167215775,0.346266169217 +-0.269723434845,0.018499549715,-0.126877892144,-0.452914378473 +-0.269723434845,0.018499549715,-0.126877892144,-0.364165844582 +-0.269723434845,0.018499549715,-0.126877892144,-0.319791577637 +-0.269723434845,0.018499549715,-0.126877892144,-0.275417310691 +-0.269723434845,0.018499549715,-0.126877892144,-0.1866687768 +-0.269723434845,0.018499549715,-0.126877892144,-0.142294509854 +-0.269723434845,0.018499549715,-0.126877892144,-0.0979202429087 +-0.269723434845,0.018499549715,-0.126877892144,-0.0535459759631 +-0.269723434845,0.018499549715,-0.126877892144,0.0352025579281 +-0.269723434845,0.018499549715,-0.126877892144,0.0795768248736 +-0.269723434845,0.018499549715,-0.126877892144,0.123951091819 +-0.269723434845,0.018499549715,-0.126877892144,0.21269962571 +-0.269723434845,0.018499549715,-0.126877892144,0.257073892656 +-0.269723434845,0.018499549715,-0.126877892144,0.301448159602 +-0.269723434845,0.018499549715,-0.126877892144,0.345822426547 +-0.269723434845,0.018499549715,-0.126877892144,0.346266169217 +-0.269723434845,0.018499549715,0.0737007551197,-0.452914378473 +-0.269723434845,0.018499549715,0.0737007551197,-0.319791577637 +-0.269723434845,0.018499549715,0.0737007551197,-0.275417310691 +-0.269723434845,0.018499549715,0.0737007551197,-0.1866687768 +-0.269723434845,0.018499549715,0.0737007551197,-0.142294509854 +-0.269723434845,0.018499549715,0.0737007551197,-0.0979202429087 +-0.269723434845,0.018499549715,0.0737007551197,-0.0535459759631 +-0.269723434845,0.018499549715,0.0737007551197,0.0352025579281 +-0.269723434845,0.018499549715,0.0737007551197,0.0795768248736 +-0.269723434845,0.018499549715,0.0737007551197,0.123951091819 +-0.269723434845,0.018499549715,0.0737007551197,0.21269962571 +-0.269723434845,0.018499549715,0.0737007551197,0.257073892656 +-0.269723434845,0.018499549715,0.0737007551197,0.301448159602 +-0.269723434845,0.018499549715,0.0737007551197,0.345822426547 +-0.269723434845,0.018499549715,0.0737007551197,0.346266169217 +-0.269723434845,0.018499549715,0.474858049646,-0.452914378473 +-0.269723434845,0.018499549715,0.474858049646,-0.364165844582 +-0.269723434845,0.018499549715,0.474858049646,-0.319791577637 +-0.269723434845,0.018499549715,0.474858049646,-0.275417310691 +-0.269723434845,0.018499549715,0.474858049646,-0.1866687768 +-0.269723434845,0.018499549715,0.474858049646,-0.142294509854 +-0.269723434845,0.018499549715,0.474858049646,-0.0979202429087 +-0.269723434845,0.018499549715,0.474858049646,-0.0535459759631 +-0.269723434845,0.018499549715,0.474858049646,0.0352025579281 +-0.269723434845,0.018499549715,0.474858049646,0.0795768248736 +-0.269723434845,0.018499549715,0.474858049646,0.123951091819 +-0.269723434845,0.018499549715,0.474858049646,0.21269962571 +-0.269723434845,0.018499549715,0.474858049646,0.257073892656 +-0.269723434845,0.018499549715,0.474858049646,0.301448159602 +-0.269723434845,0.018499549715,0.474858049646,0.345822426547 +-0.269723434845,0.018499549715,0.474858049646,0.346266169217 +0.369621003307,-0.141336559823,-0.314920373953,0.257073892656 +0.369621003307,-0.141336559823,-0.302384208499,-0.1866687768 +0.369621003307,-0.141336559823,-0.302384208499,0.0352025579281 +0.369621003307,-0.141336559823,-0.302384208499,0.0795768248736 +0.369621003307,-0.141336559823,-0.302384208499,0.21269962571 +0.369621003307,-0.141336559823,-0.302384208499,0.345822426547 +0.369621003307,-0.141336559823,-0.277311877591,-0.452914378473 +0.369621003307,-0.141336559823,-0.277311877591,-0.1866687768 +0.369621003307,-0.141336559823,-0.277311877591,-0.142294509854 +0.369621003307,-0.141336559823,-0.277311877591,-0.0979202429087 +0.369621003307,-0.141336559823,-0.277311877591,-0.0535459759631 +0.369621003307,-0.141336559823,-0.277311877591,0.0352025579281 +0.369621003307,-0.141336559823,-0.277311877591,0.123951091819 +0.369621003307,-0.141336559823,-0.277311877591,0.21269962571 +0.369621003307,-0.141336559823,-0.277311877591,0.257073892656 +0.369621003307,-0.141336559823,-0.277311877591,0.301448159602 +0.369621003307,-0.141336559823,-0.277311877591,0.345822426547 +0.369621003307,-0.141336559823,-0.227167215775,-0.452914378473 +0.369621003307,-0.141336559823,-0.227167215775,-0.364165844582 +0.369621003307,-0.141336559823,-0.227167215775,-0.319791577637 +0.369621003307,-0.141336559823,-0.227167215775,-0.275417310691 +0.369621003307,-0.141336559823,-0.227167215775,-0.1866687768 +0.369621003307,-0.141336559823,-0.227167215775,-0.0979202429087 +0.369621003307,-0.141336559823,-0.227167215775,-0.0535459759631 +0.369621003307,-0.141336559823,-0.227167215775,0.0352025579281 +0.369621003307,-0.141336559823,-0.227167215775,0.0795768248736 +0.369621003307,-0.141336559823,-0.227167215775,0.123951091819 +0.369621003307,-0.141336559823,-0.227167215775,0.21269962571 +0.369621003307,-0.141336559823,-0.227167215775,0.257073892656 +0.369621003307,-0.141336559823,-0.227167215775,0.345822426547 +0.369621003307,-0.141336559823,-0.227167215775,0.346266169217 +0.369621003307,-0.141336559823,-0.126877892144,-0.452914378473 +0.369621003307,-0.141336559823,-0.126877892144,-0.364165844582 +0.369621003307,-0.141336559823,-0.126877892144,-0.319791577637 +0.369621003307,-0.141336559823,-0.126877892144,-0.275417310691 +0.369621003307,-0.141336559823,-0.126877892144,-0.1866687768 +0.369621003307,-0.141336559823,-0.126877892144,-0.142294509854 +0.369621003307,-0.141336559823,-0.126877892144,-0.0979202429087 +0.369621003307,-0.141336559823,-0.126877892144,-0.0535459759631 +0.369621003307,-0.141336559823,-0.126877892144,0.0795768248736 +0.369621003307,-0.141336559823,-0.126877892144,0.123951091819 +0.369621003307,-0.141336559823,-0.126877892144,0.21269962571 +0.369621003307,-0.141336559823,-0.126877892144,0.257073892656 +0.369621003307,-0.141336559823,-0.126877892144,0.301448159602 +0.369621003307,-0.141336559823,-0.126877892144,0.345822426547 +0.369621003307,-0.141336559823,-0.126877892144,0.346266169217 +0.369621003307,-0.141336559823,0.0737007551197,-0.452914378473 +0.369621003307,-0.141336559823,0.0737007551197,-0.364165844582 +0.369621003307,-0.141336559823,0.0737007551197,-0.319791577637 +0.369621003307,-0.141336559823,0.0737007551197,-0.275417310691 +0.369621003307,-0.141336559823,0.0737007551197,-0.1866687768 +0.369621003307,-0.141336559823,0.0737007551197,-0.142294509854 +0.369621003307,-0.141336559823,0.0737007551197,-0.0979202429087 +0.369621003307,-0.141336559823,0.0737007551197,-0.0535459759631 +0.369621003307,-0.141336559823,0.0737007551197,0.0352025579281 +0.369621003307,-0.141336559823,0.0737007551197,0.0795768248736 +0.369621003307,-0.141336559823,0.0737007551197,0.123951091819 +0.369621003307,-0.141336559823,0.0737007551197,0.21269962571 +0.369621003307,-0.141336559823,0.0737007551197,0.257073892656 +0.369621003307,-0.141336559823,0.0737007551197,0.301448159602 +0.369621003307,-0.141336559823,0.0737007551197,0.345822426547 +0.369621003307,-0.141336559823,0.0737007551197,0.346266169217 +0.369621003307,-0.141336559823,0.474858049646,-0.364165844582 +0.369621003307,-0.141336559823,0.474858049646,-0.319791577637 +0.369621003307,-0.141336559823,0.474858049646,-0.275417310691 +0.369621003307,-0.141336559823,0.474858049646,-0.1866687768 +0.369621003307,-0.141336559823,0.474858049646,-0.142294509854 +0.369621003307,-0.141336559823,0.474858049646,-0.0979202429087 +0.369621003307,-0.141336559823,0.474858049646,-0.0535459759631 +0.369621003307,-0.141336559823,0.474858049646,0.0352025579281 +0.369621003307,-0.141336559823,0.474858049646,0.0795768248736 +0.369621003307,-0.141336559823,0.474858049646,0.123951091819 +0.369621003307,-0.141336559823,0.474858049646,0.21269962571 +0.369621003307,-0.141336559823,0.474858049646,0.257073892656 +0.369621003307,-0.141336559823,0.474858049646,0.301448159602 +0.369621003307,-0.141336559823,0.474858049646,0.345822426547 +0.369621003307,0.018499549715,-0.32118845668,-0.452914378473 +0.369621003307,0.018499549715,-0.32118845668,-0.1866687768 +0.369621003307,0.018499549715,-0.314920373953,0.0795768248736 +0.369621003307,0.018499549715,-0.302384208499,-0.0535459759631 +0.369621003307,0.018499549715,-0.302384208499,0.0795768248736 +0.369621003307,0.018499549715,-0.277311877591,-0.452914378473 +0.369621003307,0.018499549715,-0.277311877591,-0.1866687768 +0.369621003307,0.018499549715,-0.277311877591,-0.142294509854 +0.369621003307,0.018499549715,-0.277311877591,-0.0979202429087 +0.369621003307,0.018499549715,-0.277311877591,0.0795768248736 +0.369621003307,0.018499549715,-0.277311877591,0.123951091819 +0.369621003307,0.018499549715,-0.277311877591,0.301448159602 +0.369621003307,0.018499549715,-0.227167215775,-0.452914378473 +0.369621003307,0.018499549715,-0.227167215775,-0.364165844582 +0.369621003307,0.018499549715,-0.227167215775,-0.319791577637 +0.369621003307,0.018499549715,-0.227167215775,-0.275417310691 +0.369621003307,0.018499549715,-0.227167215775,-0.1866687768 +0.369621003307,0.018499549715,-0.227167215775,-0.142294509854 +0.369621003307,0.018499549715,-0.227167215775,-0.0979202429087 +0.369621003307,0.018499549715,-0.227167215775,0.0352025579281 +0.369621003307,0.018499549715,-0.227167215775,0.0795768248736 +0.369621003307,0.018499549715,-0.227167215775,0.123951091819 +0.369621003307,0.018499549715,-0.227167215775,0.257073892656 +0.369621003307,0.018499549715,-0.227167215775,0.301448159602 +0.369621003307,0.018499549715,-0.227167215775,0.345822426547 +0.369621003307,0.018499549715,-0.227167215775,0.346266169217 +0.369621003307,0.018499549715,-0.126877892144,-0.452914378473 +0.369621003307,0.018499549715,-0.126877892144,-0.364165844582 +0.369621003307,0.018499549715,-0.126877892144,-0.319791577637 +0.369621003307,0.018499549715,-0.126877892144,-0.275417310691 +0.369621003307,0.018499549715,-0.126877892144,-0.1866687768 +0.369621003307,0.018499549715,-0.126877892144,-0.142294509854 +0.369621003307,0.018499549715,-0.126877892144,-0.0979202429087 +0.369621003307,0.018499549715,-0.126877892144,-0.0535459759631 +0.369621003307,0.018499549715,-0.126877892144,0.0352025579281 +0.369621003307,0.018499549715,-0.126877892144,0.0795768248736 +0.369621003307,0.018499549715,-0.126877892144,0.123951091819 +0.369621003307,0.018499549715,-0.126877892144,0.21269962571 +0.369621003307,0.018499549715,-0.126877892144,0.257073892656 +0.369621003307,0.018499549715,-0.126877892144,0.301448159602 +0.369621003307,0.018499549715,-0.126877892144,0.345822426547 +0.369621003307,0.018499549715,-0.126877892144,0.346266169217 +0.369621003307,0.018499549715,0.0737007551197,-0.452914378473 +0.369621003307,0.018499549715,0.0737007551197,-0.364165844582 +0.369621003307,0.018499549715,0.0737007551197,-0.319791577637 +0.369621003307,0.018499549715,0.0737007551197,-0.275417310691 +0.369621003307,0.018499549715,0.0737007551197,-0.1866687768 +0.369621003307,0.018499549715,0.0737007551197,-0.142294509854 +0.369621003307,0.018499549715,0.0737007551197,-0.0979202429087 +0.369621003307,0.018499549715,0.0737007551197,-0.0535459759631 +0.369621003307,0.018499549715,0.0737007551197,0.0352025579281 +0.369621003307,0.018499549715,0.0737007551197,0.0795768248736 +0.369621003307,0.018499549715,0.0737007551197,0.123951091819 +0.369621003307,0.018499549715,0.0737007551197,0.21269962571 +0.369621003307,0.018499549715,0.0737007551197,0.257073892656 +0.369621003307,0.018499549715,0.0737007551197,0.301448159602 +0.369621003307,0.018499549715,0.0737007551197,0.345822426547 +0.369621003307,0.018499549715,0.0737007551197,0.346266169217 +0.369621003307,0.018499549715,0.474858049646,-0.452914378473 +0.369621003307,0.018499549715,0.474858049646,-0.364165844582 +0.369621003307,0.018499549715,0.474858049646,-0.319791577637 +0.369621003307,0.018499549715,0.474858049646,-0.275417310691 +0.369621003307,0.018499549715,0.474858049646,-0.1866687768 +0.369621003307,0.018499549715,0.474858049646,-0.142294509854 +0.369621003307,0.018499549715,0.474858049646,-0.0979202429087 +0.369621003307,0.018499549715,0.474858049646,-0.0535459759631 +0.369621003307,0.018499549715,0.474858049646,0.0352025579281 +0.369621003307,0.018499549715,0.474858049646,0.0795768248736 +0.369621003307,0.018499549715,0.474858049646,0.123951091819 +0.369621003307,0.018499549715,0.474858049646,0.21269962571 +0.369621003307,0.018499549715,0.474858049646,0.257073892656 +0.369621003307,0.018499549715,0.474858049646,0.301448159602 +0.369621003307,0.018499549715,0.474858049646,0.345822426547 +0.369621003307,0.018499549715,0.474858049646,0.346266169217 +0.369621003307,0.657843987867,-0.314920373953,-0.142294509854 +0.369621003307,0.657843987867,-0.302384208499,-0.275417310691 +0.369621003307,0.657843987867,-0.227167215775,0.0352025579281 +0.369621003307,0.657843987867,-0.227167215775,0.0795768248736 +0.369621003307,0.657843987867,-0.227167215775,0.21269962571 +0.369621003307,0.657843987867,-0.227167215775,0.257073892656 +0.369621003307,0.657843987867,-0.227167215775,0.345822426547 +0.369621003307,0.657843987867,-0.126877892144,-0.1866687768 +0.369621003307,0.657843987867,-0.126877892144,-0.0979202429087 +0.369621003307,0.657843987867,-0.126877892144,0.0795768248736 +0.369621003307,0.657843987867,-0.126877892144,0.123951091819 +0.369621003307,0.657843987867,-0.126877892144,0.21269962571 +0.369621003307,0.657843987867,-0.126877892144,0.257073892656 +0.369621003307,0.657843987867,-0.126877892144,0.301448159602 +0.369621003307,0.657843987867,-0.126877892144,0.346266169217 +0.369621003307,0.657843987867,0.0737007551197,-0.364165844582 +0.369621003307,0.657843987867,0.0737007551197,-0.319791577637 +0.369621003307,0.657843987867,0.0737007551197,-0.275417310691 +0.369621003307,0.657843987867,0.0737007551197,-0.142294509854 +0.369621003307,0.657843987867,0.0737007551197,-0.0979202429087 +0.369621003307,0.657843987867,0.0737007551197,-0.0535459759631 +0.369621003307,0.657843987867,0.0737007551197,0.0352025579281 +0.369621003307,0.657843987867,0.0737007551197,0.0795768248736 +0.369621003307,0.657843987867,0.0737007551197,0.123951091819 +0.369621003307,0.657843987867,0.0737007551197,0.21269962571 +0.369621003307,0.657843987867,0.0737007551197,0.257073892656 +0.369621003307,0.657843987867,0.0737007551197,0.301448159602 +0.369621003307,0.657843987867,0.0737007551197,0.346266169217 +0.369621003307,0.657843987867,0.474858049646,-0.364165844582 +0.369621003307,0.657843987867,0.474858049646,-0.319791577637 +0.369621003307,0.657843987867,0.474858049646,-0.275417310691 +0.369621003307,0.657843987867,0.474858049646,-0.1866687768 +0.369621003307,0.657843987867,0.474858049646,-0.142294509854 +0.369621003307,0.657843987867,0.474858049646,-0.0979202429087 +0.369621003307,0.657843987867,0.474858049646,-0.0535459759631 +0.369621003307,0.657843987867,0.474858049646,0.0352025579281 +0.369621003307,0.657843987867,0.474858049646,0.0795768248736 +0.369621003307,0.657843987867,0.474858049646,0.123951091819 +0.369621003307,0.657843987867,0.474858049646,0.21269962571 +0.369621003307,0.657843987867,0.474858049646,0.257073892656 +0.369621003307,0.657843987867,0.474858049646,0.301448159602 +0.369621003307,0.657843987867,0.474858049646,0.345822426547 +54123792898.5 +121470858147 +3638106285000000 +1.60756296822E+016 +608968852347 +2109464220090 +1.95114323448E+016 +4.79511015336E+016 +71978621444.8 +171760606787 +213930254338000 +2260365986250000 +4952124766050 +12320033283100 +18142207372800 +23349208587600 +27139210849700 +45095480912600 +45959950912100 +51163249783600 +42594030297100 +50460588023300 +117020581223000 +124276974592000 +135657389827000 +134058184922000 +155909903633000 +158623679039000 +149101586975000 +170110125803000 +189379130153000 +202649417664000 +211606038624000 +192221177785000 +310890509435000 +343863284608000 +325678957772000 +430809541156000 +509621237708000 +423033880026000 +587071910573000 +680623907917000 +744742195421000 +795203232880000 +936678892190000 +881246682507000 +942993570599000 +955993905096000 +860542692784000 +1039364661380000 +1245405462050000 +1297388336310000 +1370245414670000 +1663128355590000 +1814361376710000 +2105318599640000 +2100298307320000 +2599649103740000 +2578738300900000 +3025342943800000 +3135923494500000 +3564861626750000 +3570025096130000 +3686213190440000 +4669723123710000 +4684898895170000 +4826719683910000 +5389749756370000 +6044534351550000 +6851325747950000 +7734567028680000 +7779297080670000 +9.30286332418E+015 +1.00926858565E+016 +1.05522151095E+016 +1.21982910604E+016 +1.2609992587E+016 +1.33405755608E+016 +1.42671665485E+016 +4285579243840 +16084877279900 +13277413905400 +17174788896100 +28180447438100 +32138189428900 +33160385962500 +36238363635100 +38751306559100 +48268216906400 +82569478769100 +92601210196700 +106956785402000 +113490453007000 +127675249201000 +131124594596000 +128763881757000 +141227807849000 +121464378127000 +143027796318000 +137027644341000 +289027586148000 +296147332944000 +303981082985000 +336882250985000 +366369655254000 +351465670160000 +363887455886000 +385379497093000 +389405201045000 +426642309866000 +383576600737000 +403423009896000 +466777994043000 +393024969784000 +1.07529193278E+015 +1212290395850000 +1360495959340000 +1267032305850000 +1579946207100000 +1682730063730000 +1837083159410000 +1952434534600000 +2258066181040000 +2199017638930000 +2369976083480000 +2508934799420000 +2615627160430000 +2467736541880000 +2311519439160000 +2512342637980000 +4821893659190000 +5211870731540000 +5108186953080000 +5880905088600000 +6409003486990000 +7212228267580000 +7301329218060000 +8120246131829999 +8917162511430000 +9.44600159965E+015 +9.92519305348E+015 +1.06847967479E+016 +1.11602461031E+016 +1.16605949281E+016 +1.2404906342E+016 +1.47082922807E+016 +1.9334186207E+016 +2.13511675373E+016 +2.14548308013E+016 +2.2859694152E+016 +2.59389616184E+016 +2.87801886438E+016 +2.78806945582E+016 +3.01488266172E+016 +3.64364012616E+016 +3.25456520238E+016 +3.47706674567E+016 +4.17357684136E+016 +4.28330927938E+016 +4.61746688249E+016 +4.68746738207E+016 +5.86310092028E+016 +161313172246 +6146526348210 +7100908376540 +8894783132820 +9759943236600 +21423689301300 +29089817483500 +34093380254800 +35164311442600 +43848080490600 +53886899790600 +67874183459300 +106021835044000 +77891036339500 +99061284120300 +100403765820000 +93645420902800 +144469815731000 +179151679296000 +160491636495000 +194372691490000 +217725481323000 +264204514987000 +273939300389000 +284658524669000 +290171264538000 +297842220440000 +349831569845000 +353265521656000 +308013338658000 +386805934395000 +604122205000000 +722717949023000 +749850832551000 +824653093717000 +941936090972000 +1008413510510000 +1.08548059417E+015 +1.09829839811E+015 +1462322494640000 +1586488666570000 +1726228067520000 +1923715305150000 +1419911971280000 +1716396258210000 +1684446185460000 +1451929761320000 +2376387855790000 +2649902169240000 +3066230645040000 +3726146925770000 +4030518397640000 +4059079175860000 +4500661601090000 +5772453637770000 +6007838111710000 +6815348851990000 +7616939522400000 +8312821381450000 +8738898800779999 +9.11630169607E+015 +1.09835614115E+016 +8343780006159999 +1.08306165432E+016 +1.24988238013E+016 +1.3468271848E+016 +1.59065184514E+016 +1.75313776237E+016 +1.76683606367E+016 +1.9866608854E+016 +2.55440361956E+016 +2.5635755578E+016 +2.68937730675E+016 +3.1368597008E+016 +3.39406468359E+016 +3.79073721256E+016 +3.71035574968E+016 +4.73307069277E+016 +14548576521000 +22617940609900 +30416035115500 +24369589167900 +25521710913900 +26256508403600 +70613243515300 +75711163713700 +88667662560800 +78846150858700 +101304530408000 +73820439039100 +86134451492900 +97120102547600 +107937470928000 +76772646861400 +95768123137600 +259824500199000 +259036048936000 +317361440008000 +280161847991000 +357554600763000 +354835053285000 +334707061497000 +296837869770000 +356701295781000 +355796792955000 +435834817407000 +348390160037000 +570792101029000 +441676120624000 +1243375266240000 +1.07168673783E+015 +1338815069960000 +1335943361720000 +1409272934510000 +1293485118490000 +1441102243750000 +1699362645320000 +1958946332550000 +1993752638680000 +1714871826870000 +1644847813380000 +2040549880390000 +1.95324833727E+015 +1835901040890000 +4077632427900000 +4889358610380000 +4697639417870000 +5135152422500000 +5000526808520000 +5831774490310000 +5605058618770000 +5824399422830000 +6364100327060000 +6532097085870000 +7046024070610000 +7058208648170000 +8823823172159999 +8565404304579999 +7429792866730000 +8135844935040000 +2.10475722875E+016 +1.71297623448E+016 +2.17527304455E+016 +2.62743616984E+016 +2.0605339779E+016 +2.45471732842E+016 +2.66092897977E+016 +3.23551690226E+016 +2.46590658581E+016 +2.93431136321E+016 +3.70602446674E+016 +3.96026518214E+016 +3.68405194831E+016 +4.41958125837E+016 +1756374854070 +2556174983140 +8111595952740 +19832031992500 +11140556807000 +40621373640000 +63844995591500 +58316526435100 +49282223580700 +57328401189200 +51861080687500 +55613140260100 +132176990525000 +200313850588000 +174859753820000 +187684112868000 +190568512012000 +238351890972000 +185145019845000 +262597022284000 +233368141744000 +292675777437000 +305566175200000 +247592610994000 +314860222428000 +286685200916000 +740023584612000 +686988468141000 +695786792995000 +816213001296000 +915602863083000 +878027958723000 +888582874165000 +974544517036000 +868889259897000 +1182941925080000 +963103253627000 +1262014020880000 +1146522461310000 +1386542698880000 +1198601438000000 +1314124018070000 +2725958694180000 +2475524399380000 +3041646727840000 +3292886381200000 +3700247028600000 +3161457499880000 +3898961472050000 +3698701351470000 +4407324534340000 +4.08190725049E+015 +4186550068870000 +3926453399800000 +5392945300410000 +4435321286360000 +5047417285370000 +5054628605600000 +1.3109495594E+016 +1.09403912425E+016 +9.99676438926E+015 +1.0767202472E+016 +1.43210146701E+016 +1.35894311704E+016 +1.3422289038E+016 +1.27240570228E+016 +1.97166329127E+016 +1.75182168132E+016 +1.85349216508E+016 +1.91821683896E+016 +2.03133755825E+016 +1.81906352935E+016 +2.29978882342E+016 +2.00913447742E+016 +988956603493 +3553603079600 +62958418004000 +59400524191400 +83407450316900 +65572677829700 +84364531918100 +72480150655100 +91424775022100 +204977960789000 +112276529053000 +270065974142000 +208000523684000 +226507716826000 +278686789834000 +203510820353000 +224510263726000 +186154630320000 +239667454588000 +408940190264000 +447587807344000 +412428554779000 +395727033684000 +371527732444000 +468010465514000 +553990494377000 +535098907444000 +654773728324000 +978214755119000 +797892944175000 +895482127406000 +1195840287340000 +723687815191000 +1532191746940000 +1915578681090000 +1594102374250000 +1493104126630000 +736986471019000 +1519998138570000 +2414228080600000 +1435918033030000 +1561546945390000 +-0.429559544383,-0.141336559823,-0.324322498044,-0.364165844582 +-0.429559544383,-0.141336559823,-0.324322498044,-0.319791577637 +-0.429559544383,-0.141336559823,-0.324322498044,-0.275417310691 +-0.429559544383,-0.141336559823,-0.324322498044,-0.1866687768 +-0.429559544383,-0.141336559823,-0.324322498044,-0.142294509854 +-0.429559544383,-0.141336559823,-0.324322498044,-0.0979202429087 +-0.429559544383,-0.141336559823,-0.324322498044,-0.0535459759631 +-0.429559544383,-0.141336559823,-0.324322498044,0.0352025579281 +-0.429559544383,-0.141336559823,-0.324322498044,0.0795768248736 +-0.429559544383,-0.141336559823,-0.324322498044,0.123951091819 +-0.429559544383,-0.141336559823,-0.324322498044,0.21269962571 +-0.429559544383,-0.141336559823,-0.324322498044,0.257073892656 +-0.429559544383,-0.141336559823,-0.324322498044,0.301448159602 +-0.429559544383,-0.141336559823,-0.324322498044,0.345822426547 +-0.429559544383,-0.141336559823,-0.32118845668,-0.452914378473 +-0.429559544383,-0.141336559823,-0.32118845668,-0.364165844582 +-0.429559544383,-0.141336559823,-0.32118845668,-0.319791577637 +-0.429559544383,-0.141336559823,-0.32118845668,-0.275417310691 +-0.429559544383,-0.141336559823,-0.32118845668,-0.1866687768 +-0.429559544383,-0.141336559823,-0.32118845668,-0.142294509854 +-0.429559544383,-0.141336559823,-0.32118845668,-0.0979202429087 +-0.429559544383,-0.141336559823,-0.32118845668,-0.0535459759631 +-0.429559544383,-0.141336559823,-0.32118845668,0.0352025579281 +-0.429559544383,-0.141336559823,-0.32118845668,0.0795768248736 +-0.429559544383,-0.141336559823,-0.32118845668,0.123951091819 +-0.429559544383,-0.141336559823,-0.32118845668,0.21269962571 +-0.429559544383,-0.141336559823,-0.32118845668,0.257073892656 +-0.429559544383,-0.141336559823,-0.32118845668,0.301448159602 +-0.429559544383,-0.141336559823,-0.32118845668,0.345822426547 +-0.429559544383,-0.141336559823,-0.32118845668,0.346266169217 +-0.429559544383,-0.141336559823,-0.314920373953,-0.452914378473 +-0.429559544383,-0.141336559823,-0.314920373953,-0.364165844582 +-0.429559544383,-0.141336559823,-0.314920373953,-0.319791577637 +-0.429559544383,-0.141336559823,-0.314920373953,-0.275417310691 +-0.429559544383,-0.141336559823,-0.314920373953,-0.1866687768 +-0.429559544383,-0.141336559823,-0.314920373953,-0.142294509854 +-0.429559544383,-0.141336559823,-0.314920373953,-0.0979202429087 +-0.429559544383,-0.141336559823,-0.314920373953,-0.0535459759631 +-0.429559544383,-0.141336559823,-0.314920373953,0.0352025579281 +-0.429559544383,-0.141336559823,-0.314920373953,0.0795768248736 +-0.429559544383,-0.141336559823,-0.314920373953,0.123951091819 +-0.429559544383,-0.141336559823,-0.314920373953,0.21269962571 +-0.429559544383,-0.141336559823,-0.314920373953,0.257073892656 +-0.429559544383,-0.141336559823,-0.314920373953,0.301448159602 +-0.429559544383,-0.141336559823,-0.314920373953,0.345822426547 +-0.429559544383,-0.141336559823,-0.314920373953,0.346266169217 +-0.429559544383,-0.141336559823,-0.302384208499,-0.364165844582 +-0.429559544383,-0.141336559823,-0.302384208499,-0.319791577637 +-0.429559544383,-0.141336559823,-0.302384208499,-0.275417310691 +-0.429559544383,-0.141336559823,-0.302384208499,-0.1866687768 +-0.429559544383,-0.141336559823,-0.302384208499,-0.142294509854 +-0.429559544383,-0.141336559823,-0.302384208499,-0.0979202429087 +-0.429559544383,-0.141336559823,-0.302384208499,-0.0535459759631 +-0.429559544383,-0.141336559823,-0.302384208499,0.0352025579281 +-0.429559544383,-0.141336559823,-0.302384208499,0.0795768248736 +-0.429559544383,-0.141336559823,-0.302384208499,0.123951091819 +-0.429559544383,-0.141336559823,-0.302384208499,0.257073892656 +-0.429559544383,-0.141336559823,-0.302384208499,0.301448159602 +-0.429559544383,-0.141336559823,-0.302384208499,0.345822426547 +-0.429559544383,-0.141336559823,-0.302384208499,0.346266169217 +-0.429559544383,-0.141336559823,-0.277311877591,-0.319791577637 +-0.429559544383,-0.141336559823,-0.277311877591,-0.1866687768 +-0.429559544383,-0.141336559823,-0.277311877591,-0.142294509854 +-0.429559544383,-0.141336559823,-0.277311877591,-0.0979202429087 +-0.429559544383,-0.141336559823,-0.277311877591,-0.0535459759631 +-0.429559544383,-0.141336559823,-0.277311877591,0.0352025579281 +-0.429559544383,-0.141336559823,-0.277311877591,0.257073892656 +-0.429559544383,-0.141336559823,-0.277311877591,0.301448159602 +-0.429559544383,-0.141336559823,-0.227167215775,-0.452914378473 +-0.429559544383,-0.141336559823,-0.227167215775,-0.364165844582 +-0.429559544383,-0.141336559823,-0.227167215775,-0.319791577637 +-0.429559544383,-0.141336559823,-0.227167215775,-0.275417310691 +-0.429559544383,-0.141336559823,-0.126877892144,-0.452914378473 +-0.269723434845,-0.141336559823,-0.324322498044,-0.452914378473 +-0.269723434845,-0.141336559823,-0.324322498044,-0.364165844582 +-0.269723434845,-0.141336559823,-0.324322498044,-0.319791577637 +-0.269723434845,-0.141336559823,-0.324322498044,-0.275417310691 +-0.269723434845,-0.141336559823,-0.324322498044,-0.1866687768 +-0.269723434845,-0.141336559823,-0.324322498044,-0.142294509854 +-0.269723434845,-0.141336559823,-0.324322498044,-0.0979202429087 +-0.269723434845,-0.141336559823,-0.324322498044,-0.0535459759631 +-0.269723434845,-0.141336559823,-0.324322498044,0.0352025579281 +-0.269723434845,-0.141336559823,-0.324322498044,0.0795768248736 +-0.269723434845,-0.141336559823,-0.324322498044,0.123951091819 +-0.269723434845,-0.141336559823,-0.324322498044,0.21269962571 +-0.269723434845,-0.141336559823,-0.324322498044,0.257073892656 +-0.269723434845,-0.141336559823,-0.324322498044,0.301448159602 +-0.269723434845,-0.141336559823,-0.324322498044,0.345822426547 +-0.269723434845,-0.141336559823,-0.324322498044,0.346266169217 +-0.269723434845,-0.141336559823,-0.32118845668,-0.452914378473 +-0.269723434845,-0.141336559823,-0.32118845668,-0.364165844582 +-0.269723434845,-0.141336559823,-0.32118845668,-0.319791577637 +-0.269723434845,-0.141336559823,-0.32118845668,-0.275417310691 +-0.269723434845,-0.141336559823,-0.32118845668,-0.1866687768 +-0.269723434845,-0.141336559823,-0.32118845668,-0.142294509854 +-0.269723434845,-0.141336559823,-0.32118845668,-0.0979202429087 +-0.269723434845,-0.141336559823,-0.32118845668,-0.0535459759631 +-0.269723434845,-0.141336559823,-0.32118845668,0.0352025579281 +-0.269723434845,-0.141336559823,-0.32118845668,0.0795768248736 +-0.269723434845,-0.141336559823,-0.32118845668,0.123951091819 +-0.269723434845,-0.141336559823,-0.32118845668,0.257073892656 +-0.269723434845,-0.141336559823,-0.32118845668,0.301448159602 +-0.269723434845,-0.141336559823,-0.32118845668,0.345822426547 +-0.269723434845,-0.141336559823,-0.32118845668,0.346266169217 +-0.269723434845,-0.141336559823,-0.314920373953,-0.452914378473 +-0.269723434845,-0.141336559823,-0.314920373953,-0.364165844582 +-0.269723434845,-0.141336559823,-0.314920373953,-0.319791577637 +-0.269723434845,-0.141336559823,-0.314920373953,-0.275417310691 +-0.269723434845,-0.141336559823,-0.314920373953,-0.1866687768 +-0.269723434845,-0.141336559823,-0.314920373953,-0.142294509854 +-0.269723434845,-0.141336559823,-0.314920373953,-0.0979202429087 +-0.269723434845,-0.141336559823,-0.314920373953,-0.0535459759631 +-0.269723434845,-0.141336559823,-0.314920373953,0.123951091819 +-0.269723434845,-0.141336559823,-0.314920373953,0.21269962571 +-0.269723434845,-0.141336559823,-0.314920373953,0.257073892656 +-0.269723434845,-0.141336559823,-0.314920373953,0.345822426547 +-0.269723434845,-0.141336559823,-0.314920373953,0.346266169217 +-0.269723434845,-0.141336559823,-0.302384208499,-0.452914378473 +-0.269723434845,-0.141336559823,-0.302384208499,-0.319791577637 +-0.269723434845,-0.141336559823,-0.302384208499,-0.142294509854 +-0.269723434845,-0.141336559823,-0.302384208499,-0.0535459759631 +-0.269723434845,-0.141336559823,-0.302384208499,0.0352025579281 +-0.269723434845,-0.141336559823,-0.302384208499,0.123951091819 +-0.269723434845,-0.141336559823,-0.302384208499,0.21269962571 +-0.269723434845,-0.141336559823,-0.302384208499,0.257073892656 +-0.269723434845,-0.141336559823,-0.302384208499,0.345822426547 +-0.269723434845,-0.141336559823,-0.302384208499,0.346266169217 +-0.269723434845,-0.141336559823,-0.277311877591,-0.364165844582 +-0.269723434845,-0.141336559823,-0.277311877591,-0.319791577637 +-0.269723434845,-0.141336559823,-0.277311877591,-0.1866687768 +-0.269723434845,-0.141336559823,-0.277311877591,-0.0535459759631 +-0.269723434845,-0.141336559823,-0.277311877591,0.301448159602 +-0.269723434845,-0.141336559823,-0.227167215775,-0.1866687768 +-0.269723434845,-0.141336559823,-0.227167215775,-0.142294509854 +-0.269723434845,0.018499549715,-0.324322498044,-0.364165844582 +-0.269723434845,0.018499549715,-0.324322498044,-0.319791577637 +-0.269723434845,0.018499549715,-0.324322498044,-0.275417310691 +-0.269723434845,0.018499549715,-0.324322498044,-0.1866687768 +-0.269723434845,0.018499549715,-0.324322498044,-0.142294509854 +-0.269723434845,0.018499549715,-0.324322498044,-0.0979202429087 +-0.269723434845,0.018499549715,-0.324322498044,-0.0535459759631 +-0.269723434845,0.018499549715,-0.324322498044,0.0352025579281 +-0.269723434845,0.018499549715,-0.324322498044,0.0795768248736 +-0.269723434845,0.018499549715,-0.324322498044,0.123951091819 +-0.269723434845,0.018499549715,-0.324322498044,0.21269962571 +-0.269723434845,0.018499549715,-0.324322498044,0.257073892656 +-0.269723434845,0.018499549715,-0.324322498044,0.301448159602 +-0.269723434845,0.018499549715,-0.324322498044,0.345822426547 +-0.269723434845,0.018499549715,-0.324322498044,0.346266169217 +-0.269723434845,0.018499549715,-0.32118845668,-0.452914378473 +-0.269723434845,0.018499549715,-0.32118845668,-0.364165844582 +-0.269723434845,0.018499549715,-0.32118845668,-0.319791577637 +-0.269723434845,0.018499549715,-0.32118845668,-0.275417310691 +-0.269723434845,0.018499549715,-0.32118845668,-0.1866687768 +-0.269723434845,0.018499549715,-0.32118845668,-0.142294509854 +-0.269723434845,0.018499549715,-0.32118845668,-0.0979202429087 +-0.269723434845,0.018499549715,-0.32118845668,-0.0535459759631 +-0.269723434845,0.018499549715,-0.32118845668,0.0352025579281 +-0.269723434845,0.018499549715,-0.32118845668,0.0795768248736 +-0.269723434845,0.018499549715,-0.32118845668,0.123951091819 +-0.269723434845,0.018499549715,-0.32118845668,0.21269962571 +-0.269723434845,0.018499549715,-0.32118845668,0.257073892656 +-0.269723434845,0.018499549715,-0.32118845668,0.301448159602 +-0.269723434845,0.018499549715,-0.32118845668,0.345822426547 +-0.269723434845,0.018499549715,-0.32118845668,0.346266169217 +-0.269723434845,0.018499549715,-0.314920373953,-0.452914378473 +-0.269723434845,0.018499549715,-0.314920373953,-0.364165844582 +-0.269723434845,0.018499549715,-0.314920373953,-0.319791577637 +-0.269723434845,0.018499549715,-0.314920373953,-0.275417310691 +-0.269723434845,0.018499549715,-0.314920373953,-0.1866687768 +-0.269723434845,0.018499549715,-0.314920373953,-0.142294509854 +-0.269723434845,0.018499549715,-0.314920373953,-0.0979202429087 +-0.269723434845,0.018499549715,-0.314920373953,-0.0535459759631 +-0.269723434845,0.018499549715,-0.314920373953,0.0352025579281 +-0.269723434845,0.018499549715,-0.314920373953,0.123951091819 +-0.269723434845,0.018499549715,-0.314920373953,0.21269962571 +-0.269723434845,0.018499549715,-0.314920373953,0.257073892656 +-0.269723434845,0.018499549715,-0.314920373953,0.345822426547 +-0.269723434845,0.018499549715,-0.302384208499,-0.364165844582 +-0.269723434845,0.018499549715,-0.302384208499,-0.319791577637 +-0.269723434845,0.018499549715,-0.302384208499,-0.275417310691 +-0.269723434845,0.018499549715,-0.302384208499,-0.1866687768 +-0.269723434845,0.018499549715,-0.302384208499,-0.142294509854 +-0.269723434845,0.018499549715,-0.302384208499,-0.0979202429087 +-0.269723434845,0.018499549715,-0.302384208499,-0.0535459759631 +-0.269723434845,0.018499549715,-0.302384208499,0.0352025579281 +-0.269723434845,0.018499549715,-0.302384208499,0.123951091819 +-0.269723434845,0.018499549715,-0.302384208499,0.257073892656 +-0.269723434845,0.018499549715,-0.302384208499,0.301448159602 +-0.269723434845,0.018499549715,-0.302384208499,0.346266169217 +-0.269723434845,0.018499549715,-0.277311877591,-0.319791577637 +-0.269723434845,0.018499549715,-0.277311877591,-0.1866687768 +-0.269723434845,0.018499549715,-0.277311877591,-0.142294509854 +-0.269723434845,0.018499549715,-0.277311877591,-0.0535459759631 +-0.269723434845,0.018499549715,-0.277311877591,0.0352025579281 +-0.269723434845,0.018499549715,-0.277311877591,0.257073892656 +-0.269723434845,0.018499549715,-0.277311877591,0.346266169217 +-0.269723434845,0.018499549715,-0.227167215775,0.123951091819 +-0.269723434845,0.018499549715,-0.227167215775,0.21269962571 +-0.269723434845,0.018499549715,0.0737007551197,-0.364165844582 +0.369621003307,-0.141336559823,-0.324322498044,-0.364165844582 +0.369621003307,-0.141336559823,-0.324322498044,-0.319791577637 +0.369621003307,-0.141336559823,-0.324322498044,-0.275417310691 +0.369621003307,-0.141336559823,-0.324322498044,-0.1866687768 +0.369621003307,-0.141336559823,-0.324322498044,-0.142294509854 +0.369621003307,-0.141336559823,-0.324322498044,-0.0979202429087 +0.369621003307,-0.141336559823,-0.324322498044,-0.0535459759631 +0.369621003307,-0.141336559823,-0.324322498044,0.0352025579281 +0.369621003307,-0.141336559823,-0.324322498044,0.0795768248736 +0.369621003307,-0.141336559823,-0.324322498044,0.123951091819 +0.369621003307,-0.141336559823,-0.324322498044,0.21269962571 +0.369621003307,-0.141336559823,-0.324322498044,0.257073892656 +0.369621003307,-0.141336559823,-0.324322498044,0.301448159602 +0.369621003307,-0.141336559823,-0.324322498044,0.345822426547 +0.369621003307,-0.141336559823,-0.32118845668,-0.452914378473 +0.369621003307,-0.141336559823,-0.32118845668,-0.364165844582 +0.369621003307,-0.141336559823,-0.32118845668,-0.319791577637 +0.369621003307,-0.141336559823,-0.32118845668,-0.275417310691 +0.369621003307,-0.141336559823,-0.32118845668,-0.1866687768 +0.369621003307,-0.141336559823,-0.32118845668,-0.142294509854 +0.369621003307,-0.141336559823,-0.32118845668,-0.0979202429087 +0.369621003307,-0.141336559823,-0.32118845668,-0.0535459759631 +0.369621003307,-0.141336559823,-0.32118845668,0.0352025579281 +0.369621003307,-0.141336559823,-0.32118845668,0.0795768248736 +0.369621003307,-0.141336559823,-0.32118845668,0.123951091819 +0.369621003307,-0.141336559823,-0.32118845668,0.21269962571 +0.369621003307,-0.141336559823,-0.32118845668,0.257073892656 +0.369621003307,-0.141336559823,-0.32118845668,0.301448159602 +0.369621003307,-0.141336559823,-0.32118845668,0.345822426547 +0.369621003307,-0.141336559823,-0.32118845668,0.346266169217 +0.369621003307,-0.141336559823,-0.314920373953,-0.452914378473 +0.369621003307,-0.141336559823,-0.314920373953,-0.364165844582 +0.369621003307,-0.141336559823,-0.314920373953,-0.319791577637 +0.369621003307,-0.141336559823,-0.314920373953,-0.275417310691 +0.369621003307,-0.141336559823,-0.314920373953,-0.1866687768 +0.369621003307,-0.141336559823,-0.314920373953,-0.142294509854 +0.369621003307,-0.141336559823,-0.314920373953,-0.0979202429087 +0.369621003307,-0.141336559823,-0.314920373953,-0.0535459759631 +0.369621003307,-0.141336559823,-0.314920373953,0.0352025579281 +0.369621003307,-0.141336559823,-0.314920373953,0.0795768248736 +0.369621003307,-0.141336559823,-0.314920373953,0.123951091819 +0.369621003307,-0.141336559823,-0.314920373953,0.21269962571 +0.369621003307,-0.141336559823,-0.314920373953,0.301448159602 +0.369621003307,-0.141336559823,-0.314920373953,0.345822426547 +0.369621003307,-0.141336559823,-0.314920373953,0.346266169217 +0.369621003307,-0.141336559823,-0.302384208499,-0.452914378473 +0.369621003307,-0.141336559823,-0.302384208499,-0.364165844582 +0.369621003307,-0.141336559823,-0.302384208499,-0.319791577637 +0.369621003307,-0.141336559823,-0.302384208499,-0.275417310691 +0.369621003307,-0.141336559823,-0.302384208499,-0.142294509854 +0.369621003307,-0.141336559823,-0.302384208499,-0.0979202429087 +0.369621003307,-0.141336559823,-0.302384208499,-0.0535459759631 +0.369621003307,-0.141336559823,-0.302384208499,0.123951091819 +0.369621003307,-0.141336559823,-0.302384208499,0.257073892656 +0.369621003307,-0.141336559823,-0.302384208499,0.301448159602 +0.369621003307,-0.141336559823,-0.302384208499,0.346266169217 +0.369621003307,-0.141336559823,-0.277311877591,-0.364165844582 +0.369621003307,-0.141336559823,-0.277311877591,-0.319791577637 +0.369621003307,-0.141336559823,-0.277311877591,-0.275417310691 +0.369621003307,-0.141336559823,-0.277311877591,0.0795768248736 +0.369621003307,-0.141336559823,-0.277311877591,0.346266169217 +0.369621003307,-0.141336559823,-0.227167215775,-0.142294509854 +0.369621003307,-0.141336559823,-0.227167215775,0.301448159602 +0.369621003307,-0.141336559823,-0.126877892144,0.0352025579281 +0.369621003307,0.018499549715,-0.324322498044,-0.452914378473 +0.369621003307,0.018499549715,-0.324322498044,-0.364165844582 +0.369621003307,0.018499549715,-0.324322498044,-0.319791577637 +0.369621003307,0.018499549715,-0.324322498044,-0.275417310691 +0.369621003307,0.018499549715,-0.324322498044,-0.1866687768 +0.369621003307,0.018499549715,-0.324322498044,-0.142294509854 +0.369621003307,0.018499549715,-0.324322498044,-0.0979202429087 +0.369621003307,0.018499549715,-0.324322498044,-0.0535459759631 +0.369621003307,0.018499549715,-0.324322498044,0.0352025579281 +0.369621003307,0.018499549715,-0.324322498044,0.0795768248736 +0.369621003307,0.018499549715,-0.324322498044,0.123951091819 +0.369621003307,0.018499549715,-0.324322498044,0.21269962571 +0.369621003307,0.018499549715,-0.324322498044,0.257073892656 +0.369621003307,0.018499549715,-0.324322498044,0.301448159602 +0.369621003307,0.018499549715,-0.324322498044,0.345822426547 +0.369621003307,0.018499549715,-0.324322498044,0.346266169217 +0.369621003307,0.018499549715,-0.32118845668,-0.364165844582 +0.369621003307,0.018499549715,-0.32118845668,-0.319791577637 +0.369621003307,0.018499549715,-0.32118845668,-0.275417310691 +0.369621003307,0.018499549715,-0.32118845668,-0.142294509854 +0.369621003307,0.018499549715,-0.32118845668,-0.0979202429087 +0.369621003307,0.018499549715,-0.32118845668,-0.0535459759631 +0.369621003307,0.018499549715,-0.32118845668,0.0352025579281 +0.369621003307,0.018499549715,-0.32118845668,0.0795768248736 +0.369621003307,0.018499549715,-0.32118845668,0.123951091819 +0.369621003307,0.018499549715,-0.32118845668,0.21269962571 +0.369621003307,0.018499549715,-0.32118845668,0.257073892656 +0.369621003307,0.018499549715,-0.32118845668,0.301448159602 +0.369621003307,0.018499549715,-0.32118845668,0.345822426547 +0.369621003307,0.018499549715,-0.32118845668,0.346266169217 +0.369621003307,0.018499549715,-0.314920373953,-0.452914378473 +0.369621003307,0.018499549715,-0.314920373953,-0.364165844582 +0.369621003307,0.018499549715,-0.314920373953,-0.319791577637 +0.369621003307,0.018499549715,-0.314920373953,-0.275417310691 +0.369621003307,0.018499549715,-0.314920373953,-0.1866687768 +0.369621003307,0.018499549715,-0.314920373953,-0.142294509854 +0.369621003307,0.018499549715,-0.314920373953,-0.0979202429087 +0.369621003307,0.018499549715,-0.314920373953,-0.0535459759631 +0.369621003307,0.018499549715,-0.314920373953,0.0352025579281 +0.369621003307,0.018499549715,-0.314920373953,0.123951091819 +0.369621003307,0.018499549715,-0.314920373953,0.21269962571 +0.369621003307,0.018499549715,-0.314920373953,0.257073892656 +0.369621003307,0.018499549715,-0.314920373953,0.301448159602 +0.369621003307,0.018499549715,-0.314920373953,0.345822426547 +0.369621003307,0.018499549715,-0.314920373953,0.346266169217 +0.369621003307,0.018499549715,-0.302384208499,-0.452914378473 +0.369621003307,0.018499549715,-0.302384208499,-0.364165844582 +0.369621003307,0.018499549715,-0.302384208499,-0.319791577637 +0.369621003307,0.018499549715,-0.302384208499,-0.275417310691 +0.369621003307,0.018499549715,-0.302384208499,-0.1866687768 +0.369621003307,0.018499549715,-0.302384208499,-0.142294509854 +0.369621003307,0.018499549715,-0.302384208499,-0.0979202429087 +0.369621003307,0.018499549715,-0.302384208499,0.0352025579281 +0.369621003307,0.018499549715,-0.302384208499,0.123951091819 +0.369621003307,0.018499549715,-0.302384208499,0.21269962571 +0.369621003307,0.018499549715,-0.302384208499,0.257073892656 +0.369621003307,0.018499549715,-0.302384208499,0.301448159602 +0.369621003307,0.018499549715,-0.302384208499,0.345822426547 +0.369621003307,0.018499549715,-0.302384208499,0.346266169217 +0.369621003307,0.018499549715,-0.277311877591,-0.364165844582 +0.369621003307,0.018499549715,-0.277311877591,-0.319791577637 +0.369621003307,0.018499549715,-0.277311877591,-0.275417310691 +0.369621003307,0.018499549715,-0.277311877591,-0.0535459759631 +0.369621003307,0.018499549715,-0.277311877591,0.0352025579281 +0.369621003307,0.018499549715,-0.277311877591,0.21269962571 +0.369621003307,0.018499549715,-0.277311877591,0.257073892656 +0.369621003307,0.018499549715,-0.277311877591,0.345822426547 +0.369621003307,0.018499549715,-0.277311877591,0.346266169217 +0.369621003307,0.018499549715,-0.227167215775,-0.0535459759631 +0.369621003307,0.018499549715,-0.227167215775,0.21269962571 +0.369621003307,0.657843987867,-0.324322498044,-0.364165844582 +0.369621003307,0.657843987867,-0.324322498044,-0.319791577637 +0.369621003307,0.657843987867,-0.324322498044,-0.275417310691 +0.369621003307,0.657843987867,-0.324322498044,-0.1866687768 +0.369621003307,0.657843987867,-0.324322498044,-0.142294509854 +0.369621003307,0.657843987867,-0.324322498044,-0.0979202429087 +0.369621003307,0.657843987867,-0.324322498044,-0.0535459759631 +0.369621003307,0.657843987867,-0.324322498044,0.0352025579281 +0.369621003307,0.657843987867,-0.324322498044,0.0795768248736 +0.369621003307,0.657843987867,-0.324322498044,0.123951091819 +0.369621003307,0.657843987867,-0.324322498044,0.21269962571 +0.369621003307,0.657843987867,-0.324322498044,0.257073892656 +0.369621003307,0.657843987867,-0.324322498044,0.301448159602 +0.369621003307,0.657843987867,-0.324322498044,0.345822426547 +0.369621003307,0.657843987867,-0.32118845668,-0.452914378473 +0.369621003307,0.657843987867,-0.32118845668,-0.364165844582 +0.369621003307,0.657843987867,-0.32118845668,-0.319791577637 +0.369621003307,0.657843987867,-0.32118845668,-0.275417310691 +0.369621003307,0.657843987867,-0.32118845668,-0.1866687768 +0.369621003307,0.657843987867,-0.32118845668,-0.142294509854 +0.369621003307,0.657843987867,-0.32118845668,-0.0979202429087 +0.369621003307,0.657843987867,-0.32118845668,-0.0535459759631 +0.369621003307,0.657843987867,-0.32118845668,0.0352025579281 +0.369621003307,0.657843987867,-0.32118845668,0.0795768248736 +0.369621003307,0.657843987867,-0.32118845668,0.123951091819 +0.369621003307,0.657843987867,-0.32118845668,0.21269962571 +0.369621003307,0.657843987867,-0.32118845668,0.257073892656 +0.369621003307,0.657843987867,-0.32118845668,0.301448159602 +0.369621003307,0.657843987867,-0.32118845668,0.345822426547 +0.369621003307,0.657843987867,-0.32118845668,0.346266169217 +0.369621003307,0.657843987867,-0.314920373953,-0.452914378473 +0.369621003307,0.657843987867,-0.314920373953,-0.364165844582 +0.369621003307,0.657843987867,-0.314920373953,-0.319791577637 +0.369621003307,0.657843987867,-0.314920373953,-0.275417310691 +0.369621003307,0.657843987867,-0.314920373953,-0.1866687768 +0.369621003307,0.657843987867,-0.314920373953,-0.0979202429087 +0.369621003307,0.657843987867,-0.314920373953,-0.0535459759631 +0.369621003307,0.657843987867,-0.314920373953,0.0352025579281 +0.369621003307,0.657843987867,-0.314920373953,0.0795768248736 +0.369621003307,0.657843987867,-0.314920373953,0.123951091819 +0.369621003307,0.657843987867,-0.314920373953,0.21269962571 +0.369621003307,0.657843987867,-0.314920373953,0.257073892656 +0.369621003307,0.657843987867,-0.314920373953,0.301448159602 +0.369621003307,0.657843987867,-0.314920373953,0.345822426547 +0.369621003307,0.657843987867,-0.314920373953,0.346266169217 +0.369621003307,0.657843987867,-0.302384208499,-0.452914378473 +0.369621003307,0.657843987867,-0.302384208499,-0.364165844582 +0.369621003307,0.657843987867,-0.302384208499,-0.319791577637 +0.369621003307,0.657843987867,-0.302384208499,-0.1866687768 +0.369621003307,0.657843987867,-0.302384208499,-0.142294509854 +0.369621003307,0.657843987867,-0.302384208499,-0.0979202429087 +0.369621003307,0.657843987867,-0.302384208499,-0.0535459759631 +0.369621003307,0.657843987867,-0.302384208499,0.0352025579281 +0.369621003307,0.657843987867,-0.302384208499,0.0795768248736 +0.369621003307,0.657843987867,-0.302384208499,0.123951091819 +0.369621003307,0.657843987867,-0.302384208499,0.21269962571 +0.369621003307,0.657843987867,-0.302384208499,0.257073892656 +0.369621003307,0.657843987867,-0.302384208499,0.301448159602 +0.369621003307,0.657843987867,-0.302384208499,0.345822426547 +0.369621003307,0.657843987867,-0.302384208499,0.346266169217 +0.369621003307,0.657843987867,-0.277311877591,-0.452914378473 +0.369621003307,0.657843987867,-0.277311877591,-0.364165844582 +0.369621003307,0.657843987867,-0.277311877591,-0.319791577637 +0.369621003307,0.657843987867,-0.277311877591,-0.275417310691 +0.369621003307,0.657843987867,-0.277311877591,-0.1866687768 +0.369621003307,0.657843987867,-0.277311877591,-0.142294509854 +0.369621003307,0.657843987867,-0.277311877591,-0.0979202429087 +0.369621003307,0.657843987867,-0.277311877591,-0.0535459759631 +0.369621003307,0.657843987867,-0.277311877591,0.0352025579281 +0.369621003307,0.657843987867,-0.277311877591,0.0795768248736 +0.369621003307,0.657843987867,-0.277311877591,0.123951091819 +0.369621003307,0.657843987867,-0.277311877591,0.21269962571 +0.369621003307,0.657843987867,-0.277311877591,0.257073892656 +0.369621003307,0.657843987867,-0.277311877591,0.301448159602 +0.369621003307,0.657843987867,-0.277311877591,0.345822426547 +0.369621003307,0.657843987867,-0.277311877591,0.346266169217 +0.369621003307,0.657843987867,-0.227167215775,-0.452914378473 +0.369621003307,0.657843987867,-0.227167215775,-0.364165844582 +0.369621003307,0.657843987867,-0.227167215775,-0.319791577637 +0.369621003307,0.657843987867,-0.227167215775,-0.275417310691 +0.369621003307,0.657843987867,-0.227167215775,-0.1866687768 +0.369621003307,0.657843987867,-0.227167215775,-0.142294509854 +0.369621003307,0.657843987867,-0.227167215775,-0.0979202429087 +0.369621003307,0.657843987867,-0.227167215775,-0.0535459759631 +0.369621003307,0.657843987867,-0.227167215775,0.123951091819 +0.369621003307,0.657843987867,-0.227167215775,0.301448159602 +0.369621003307,0.657843987867,-0.227167215775,0.346266169217 +0.369621003307,0.657843987867,-0.126877892144,-0.452914378473 +0.369621003307,0.657843987867,-0.126877892144,-0.364165844582 +0.369621003307,0.657843987867,-0.126877892144,-0.319791577637 +0.369621003307,0.657843987867,-0.126877892144,-0.275417310691 +0.369621003307,0.657843987867,-0.126877892144,-0.142294509854 +0.369621003307,0.657843987867,-0.126877892144,-0.0535459759631 +0.369621003307,0.657843987867,-0.126877892144,0.0352025579281 +0.369621003307,0.657843987867,-0.126877892144,0.345822426547 +0.369621003307,0.657843987867,0.0737007551197,-0.452914378473 +0.369621003307,0.657843987867,0.0737007551197,-0.1866687768 +0.369621003307,0.657843987867,0.0737007551197,0.345822426547 diff --git a/src/slatec.f b/src/slatec.f new file mode 100644 index 0000000..7d51578 --- /dev/null +++ b/src/slatec.f @@ -0,0 +1,5037 @@ +*DECK DLSEI + SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, + + RNORML, MODE, WS, IP) +C***BEGIN PROLOGUE DLSEI +C***PURPOSE Solve a linearly constrained least squares problem with +C equality and inequality constraints, and optionally compute +C a covariance matrix. +C***LIBRARY SLATEC +C***CATEGORY K1A2A, D9 +C***TYPE REAL(KIND=R8) (LSEI-S, DLSEI-D) +C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, +C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, +C QUADRATIC PROGRAMMING +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C Abstract +C +C This subprogram solves a linearly constrained least squares +C problem with both equality and inequality constraints, and, if the +C user requests, obtains a covariance matrix of the solution +C parameters. +C +C Suppose there are given matrices E, A and G of respective +C dimensions ME by N, MA by N and MG by N, and vectors F, B and H of +C respective lengths ME, MA and MG. This subroutine solves the +C linearly constrained least squares problem +C +C EX = F, (E ME by N) (equations to be exactly +C satisfied) +C AX = B, (A MA by N) (equations to be +C approximately satisfied, +C least squares sense) +C GX .GE. H,(G MG by N) (inequality constraints) +C +C The inequalities GX .GE. H mean that every component of the +C product GX must be .GE. the corresponding component of H. +C +C In case the equality constraints cannot be satisfied, a +C generalized inverse solution residual vector length is obtained +C for F-EX. This is the minimal length possible for F-EX. +C +C Any values ME .GE. 0, MA .GE. 0, or MG .GE. 0 are permitted. The +C rank of the matrix E is estimated during the computation. We call +C this value KRANKE. It is an output parameter in IP(1) defined +C below. Using a generalized inverse solution of EX=F, a reduced +C least squares problem with inequality constraints is obtained. +C The tolerances used in these tests for determining the rank +C of E and the rank of the reduced least squares problem are +C given in Sandia Tech. Rept. SAND-78-1290. They can be +C modified by the user if new values are provided in +C the option list of the array PRGOPT(*). +C +C The user must dimension all arrays appearing in the call list.. +C W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2) +C where K=MAX(MA+MG,N). This allows for a solution of a range of +C problems in the given working space. The dimension of WS(*) +C given is a necessary overestimate. Once a particular problem +C has been run, the output parameter IP(3) gives the actual +C dimension required for that problem. +C +C The parameters for DLSEI( ) are +C +C Input.. All TYPE REAL variables are REAL(KIND=R8) +C +C W(*,*),MDW, The array W(*,*) is doubly subscripted with +C ME,MA,MG,N first dimensioning parameter equal to MDW. +C For this discussion let us call M = ME+MA+MG. Then +C MDW must satisfy MDW .GE. M. The condition +C MDW .LT. M is an error. +C +C The array W(*,*) contains the matrices and vectors +C +C (E F) +C (A B) +C (G H) +C +C in rows and columns 1,...,M and 1,...,N+1 +C respectively. +C +C The integers ME, MA, and MG are the +C respective matrix row dimensions +C of E, A and G. Each matrix has N columns. +C +C PRGOPT(*) This real-valued array is the option vector. +C If the user is satisfied with the nominal +C subprogram features set +C +C PRGOPT(1)=1 (or PRGOPT(1)=1.0) +C +C Otherwise PRGOPT(*) is a linked list consisting of +C groups of data of the following form +C +C LINK +C KEY +C DATA SET +C +C The parameters LINK and KEY are each one word. +C The DATA SET can be comprised of several words. +C The number of items depends on the value of KEY. +C The value of LINK points to the first +C entry of the next group of data within +C PRGOPT(*). The exception is when there are +C no more options to change. In that +C case, LINK=1 and the values KEY and DATA SET +C are not referenced. The general layout of +C PRGOPT(*) is as follows. +C +C ...PRGOPT(1) = LINK1 (link to first entry of next group) +C . PRGOPT(2) = KEY1 (key to the option change) +C . PRGOPT(3) = data value (data value for this change) +C . . +C . . +C . . +C ...PRGOPT(LINK1) = LINK2 (link to the first entry of +C . next group) +C . PRGOPT(LINK1+1) = KEY2 (key to the option change) +C . PRGOPT(LINK1+2) = data value +C ... . +C . . +C . . +C ...PRGOPT(LINK) = 1 (no more options to change) +C +C Values of LINK that are nonpositive are errors. +C A value of LINK .GT. NLINK=100000 is also an error. +C This helps prevent using invalid but positive +C values of LINK that will probably extend +C beyond the program limits of PRGOPT(*). +C Unrecognized values of KEY are ignored. The +C order of the options is arbitrary and any number +C of options can be changed with the following +C restriction. To prevent cycling in the +C processing of the option array, a count of the +C number of options changed is maintained. +C Whenever this count exceeds NOPT=1000, an error +C message is printed and the subprogram returns. +C +C Options.. +C +C KEY=1 +C Compute in W(*,*) the N by N +C covariance matrix of the solution variables +C as an output parameter. Nominally the +C covariance matrix will not be computed. +C (This requires no user input.) +C The data set for this option is a single value. +C It must be nonzero when the covariance matrix +C is desired. If it is zero, the covariance +C matrix is not computed. When the covariance matrix +C is computed, the first dimensioning parameter +C of the array W(*,*) must satisfy MDW .GE. MAX(M,N). +C +C KEY=10 +C Suppress scaling of the inverse of the +C normal matrix by the scale factor RNORM**2/ +C MAX(1, no. of degrees of freedom). This option +C only applies when the option for computing the +C covariance matrix (KEY=1) is used. With KEY=1 and +C KEY=10 used as options the unscaled inverse of the +C normal matrix is returned in W(*,*). +C The data set for this option is a single value. +C When it is nonzero no scaling is done. When it is +C zero scaling is done. The nominal case is to do +C scaling so if option (KEY=1) is used alone, the +C matrix will be scaled on output. +C +C KEY=2 +C Scale the nonzero columns of the +C entire data matrix. +C (E) +C (A) +C (G) +C +C to have length one. The data set for this +C option is a single value. It must be +C nonzero if unit length column scaling +C is desired. +C +C KEY=3 +C Scale columns of the entire data matrix +C (E) +C (A) +C (G) +C +C with a user-provided diagonal matrix. +C The data set for this option consists +C of the N diagonal scaling factors, one for +C each matrix column. +C +C KEY=4 +C Change the rank determination tolerance for +C the equality constraint equations from +C the nominal value of SQRT(DRELPR). This quantity can +C be no smaller than DRELPR, the arithmetic- +C storage precision. The quantity DRELPR is the +C largest positive number such that T=1.+DRELPR +C satisfies T .EQ. 1. The quantity used +C here is internally restricted to be at +C least DRELPR. The data set for this option +C is the new tolerance. +C +C KEY=5 +C Change the rank determination tolerance for +C the reduced least squares equations from +C the nominal value of SQRT(DRELPR). This quantity can +C be no smaller than DRELPR, the arithmetic- +C storage precision. The quantity used +C here is internally restricted to be at +C least DRELPR. The data set for this option +C is the new tolerance. +C +C For example, suppose we want to change +C the tolerance for the reduced least squares +C problem, compute the covariance matrix of +C the solution parameters, and provide +C column scaling for the data matrix. For +C these options the dimension of PRGOPT(*) +C must be at least N+9. The Fortran statements +C defining these options would be as follows: +C +C PRGOPT(1)=4 (link to entry 4 in PRGOPT(*)) +C PRGOPT(2)=1 (covariance matrix key) +C PRGOPT(3)=1 (covariance matrix wanted) +C +C PRGOPT(4)=7 (link to entry 7 in PRGOPT(*)) +C PRGOPT(5)=5 (least squares equas. tolerance key) +C PRGOPT(6)=... (new value of the tolerance) +C +C PRGOPT(7)=N+9 (link to entry N+9 in PRGOPT(*)) +C PRGOPT(8)=3 (user-provided column scaling key) +C +C CALL DCOPY (N, D, 1, PRGOPT(9), 1) (Copy the N +C scaling factors from the user array D(*) +C to PRGOPT(9)-PRGOPT(N+8)) +C +C PRGOPT(N+9)=1 (no more options to change) +C +C The contents of PRGOPT(*) are not modified +C by the subprogram. +C The options for WNNLS( ) can also be included +C in this array. The values of KEY recognized +C by WNNLS( ) are 6, 7 and 8. Their functions +C are documented in the usage instructions for +C subroutine WNNLS( ). Normally these options +C do not need to be modified when using DLSEI( ). +C +C IP(1), The amounts of working storage actually +C IP(2) allocated for the working arrays WS(*) and +C IP(*), respectively. These quantities are +C compared with the actual amounts of storage +C needed by DLSEI( ). Insufficient storage +C allocated for either WS(*) or IP(*) is an +C error. This feature was included in DLSEI( ) +C because miscalculating the storage formulas +C for WS(*) and IP(*) might very well lead to +C subtle and hard-to-find execution errors. +C +C The length of WS(*) must be at least +C +C LW = 2*(ME+N)+K+(MG+2)*(N+7) +C +C where K = max(MA+MG,N) +C This test will not be made if IP(1).LE.0. +C +C The length of IP(*) must be at least +C +C LIP = MG+2*N+2 +C This test will not be made if IP(2).LE.0. +C +C Output.. All TYPE REAL variables are REAL(KIND=R8) +C +C X(*),RNORME, The array X(*) contains the solution parameters +C RNORML if the integer output flag MODE = 0 or 1. +C The definition of MODE is given directly below. +C When MODE = 0 or 1, RNORME and RNORML +C respectively contain the residual vector +C Euclidean lengths of F - EX and B - AX. When +C MODE=1 the equality constraint equations EX=F +C are contradictory, so RNORME .NE. 0. The residual +C vector F-EX has minimal Euclidean length. For +C MODE .GE. 2, none of these parameters is defined. +C +C MODE Integer flag that indicates the subprogram +C status after completion. If MODE .GE. 2, no +C solution has been computed. +C +C MODE = +C +C 0 Both equality and inequality constraints +C are compatible and have been satisfied. +C +C 1 Equality constraints are contradictory. +C A generalized inverse solution of EX=F was used +C to minimize the residual vector length F-EX. +C In this sense, the solution is still meaningful. +C +C 2 Inequality constraints are contradictory. +C +C 3 Both equality and inequality constraints +C are contradictory. +C +C The following interpretation of +C MODE=1,2 or 3 must be made. The +C sets consisting of all solutions +C of the equality constraints EX=F +C and all vectors satisfying GX .GE. H +C have no points in common. (In +C particular this does not say that +C each individual set has no points +C at all, although this could be the +C case.) +C +C 4 Usage error occurred. The value +C of MDW is .LT. ME+MA+MG, MDW is +C .LT. N and a covariance matrix is +C requested, or the option vector +C PRGOPT(*) is not properly defined, +C or the lengths of the working arrays +C WS(*) and IP(*), when specified in +C IP(1) and IP(2) respectively, are not +C long enough. +C +C W(*,*) The array W(*,*) contains the N by N symmetric +C covariance matrix of the solution parameters, +C provided this was requested on input with +C the option vector PRGOPT(*) and the output +C flag is returned with MODE = 0 or 1. +C +C IP(*) The integer working array has three entries +C that provide rank and working array length +C information after completion. +C +C IP(1) = rank of equality constraint +C matrix. Define this quantity +C as KRANKE. +C +C IP(2) = rank of reduced least squares +C problem. +C +C IP(3) = the amount of storage in the +C working array WS(*) that was +C actually used by the subprogram. +C The formula given above for the length +C of WS(*) is a necessary overestimate. +C If exactly the same problem matrices +C are used in subsequent executions, +C the declared dimension of WS(*) can +C be reduced to this output value. +C User Designated +C Working Arrays.. +C +C WS(*),IP(*) These are respectively type real +C and type integer working arrays. +C Their required minimal lengths are +C given above. +C +C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for +C linear least squares problems with equality and +C nonnegativity constraints, Report SAND77-0552, Sandia +C Laboratories, June 1978. +C K. H. Haskell and R. J. Hanson, Selected algorithms for +C the linearly constrained least squares problem - a +C users guide, Report SAND78-1290, Sandia Laboratories, +C August 1979. +C K. H. Haskell and R. J. Hanson, An algorithm for +C linear least squares problems with equality and +C nonnegativity constraints, Mathematical Programming +C 21 (1981), pp. 98-118. +C R. J. Hanson and K. H. Haskell, Two algorithms for the +C linearly constrained least squares problem, ACM +C Transactions on Mathematical Software, September 1982. +C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, +C DNRM2, DSCAL, DSWAP, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and extensively revised (WRB & RWC) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900510 Convert XERRWV calls to XERMSG calls. (RWC) +C 900604 DP version created from SP version. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C 180613 Removed prints and replaced DP --> REAL(KIND=R8). (THC) +C***END PROLOGUE DLSEI + USE REAL_PRECISION + + INTEGER IP(3), MA, MDW, ME, MG, MODE, N + REAL(KIND=R8) PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*) +C + EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, DNRM2, + * DSCAL, DSWAP + REAL(KIND=R8) D1MACH, DASUM, DDOT, DNRM2 +C + REAL(KIND=R8) DRELPR, ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, + * SN, SNMAX, T, TAU, UJ, UP, VJ, XNORM, XNRME + INTEGER I, IMAX, J, JP1, K, KEY, KRANKE, LAST, LCHK, LINK, M, + * MAPKE1, MDEQC, MEND, MEP1, N1, N2, NEXT, NLINK, NOPT, NP1, + * NTIMES + LOGICAL COV, FIRST +C CHARACTER*8 XERN1, XERN2, XERN3, XERN4 + SAVE FIRST, DRELPR +C + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DLSEI +C +C Set the nominal tolerance used in the code for the equality +C constraint equations. +C + IF (FIRST) DRELPR = D1MACH(4) + FIRST = .FALSE. + TAU = SQRT(DRELPR) +C +C Check that enough storage was allocated in WS(*) and IP(*). +C + MODE = 4 + IF (MIN(N,ME,MA,MG) .LT. 0) THEN +C WRITE (XERN1, '(I8)') N +C WRITE (XERN2, '(I8)') ME +C WRITE (XERN3, '(I8)') MA +C WRITE (XERN4, '(I8)') MG +C CALL XERMSG ('SLATEC', 'LSEI', 'ALL OF THE VARIABLES N, ME,' // +C * ' MA, MG MUST BE .GE. 0$$ENTERED ROUTINE WITH' // +C * '$$N = ' // XERN1 // +C * '$$ME = ' // XERN2 // +C * '$$MA = ' // XERN3 // +C * '$$MG = ' // XERN4, 2, 1) + RETURN + ENDIF +C + IF (IP(1).GT.0) THEN + LCHK = 2*(ME+N) + MAX(MA+MG,N) + (MG+2)*(N+7) + IF (IP(1).LT.LCHK) THEN +C WRITE (XERN1, '(I8)') LCHK +C CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // +C * 'ALLOCATED FOR WS(*), NEED LW = ' // XERN1, 2, 1) + RETURN + ENDIF + ENDIF +C + IF (IP(2).GT.0) THEN + LCHK = MG + 2*N + 2 + IF (IP(2).LT.LCHK) THEN +C WRITE (XERN1, '(I8)') LCHK +C CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // +C * 'ALLOCATED FOR IP(*), NEED LIP = ' // XERN1, 2, 1) + RETURN + ENDIF + ENDIF +C +C Compute number of possible right multiplying Householder +C transformations. +C + M = ME + MA + MG + IF (N.LE.0 .OR. M.LE.0) THEN + MODE = 0 + RNORME = 0 + RNORML = 0 + RETURN + ENDIF +C + IF (MDW.LT.M) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', 'MDW.LT.ME+MA+MG IS AN ERROR', +C + 2, 1) + RETURN + ENDIF +C + NP1 = N + 1 + KRANKE = MIN(ME,N) + N1 = 2*KRANKE + 1 + N2 = N1 + N +C +C Set nominal values. +C +C The nominal column scaling used in the code is +C the identity scaling. +C + CALL DCOPY (N, 1.D0, 0, WS(N1), 1) +C +C No covariance matrix is nominally computed. +C + COV = .FALSE. +C +C Process option vector. +C Define bound for number of options to change. +C + NOPT = 1000 + NTIMES = 0 +C +C Define bound for positive values of LINK. +C + NLINK = 100000 + LAST = 1 + LINK = PRGOPT(1) + IF (LINK.EQ.0 .OR. LINK.GT.NLINK) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', +C + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) + RETURN + ENDIF +C + 100 IF (LINK.GT.1) THEN + NTIMES = NTIMES + 1 + IF (NTIMES.GT.NOPT) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', +C + 'THE LINKS IN THE OPTION VECTOR ARE CYCLING.', 2, 1) + RETURN + ENDIF +C + KEY = PRGOPT(LAST+1) + IF (KEY.EQ.1) THEN + COV = PRGOPT(LAST+2) .NE. 0.D0 + ELSEIF (KEY.EQ.2 .AND. PRGOPT(LAST+2).NE.0.D0) THEN + DO 110 J = 1,N + T = DNRM2(M,W(1,J),1) + IF (T.NE.0.D0) T = 1.D0/T + WS(J+N1-1) = T + 110 CONTINUE + ELSEIF (KEY.EQ.3) THEN + CALL DCOPY (N, PRGOPT(LAST+2), 1, WS(N1), 1) + ELSEIF (KEY.EQ.4) THEN + TAU = MAX(DRELPR,PRGOPT(LAST+2)) + ENDIF +C + NEXT = PRGOPT(LINK) + IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', +C + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) + RETURN + ENDIF +C + LAST = LINK + LINK = NEXT + GO TO 100 + ENDIF +C + DO 120 J = 1,N + CALL DSCAL (M, WS(N1+J-1), W(1,J), 1) + 120 CONTINUE +C + IF (COV .AND. MDW.LT.N) THEN +C CALL XERMSG ('SLATEC', 'DLSEI', +C + 'MDW .LT. N WHEN COV MATRIX NEEDED, IS AN ERROR', 2, 1) + RETURN + ENDIF +C +C Problem definition and option vector OK. +C + MODE = 0 +C +C Compute norm of equality constraint matrix and right side. +C + ENORM = 0.D0 + DO 130 J = 1,N + ENORM = MAX(ENORM,DASUM(ME,W(1,J),1)) + 130 CONTINUE +C + FNORM = DASUM(ME,W(1,NP1),1) + SNMAX = 0.D0 + RNMAX = 0.D0 + DO 150 I = 1,KRANKE +C +C Compute maximum ratio of vector lengths. Partition is at +C column I. +C + DO 140 K = I,ME + SN = DDOT(N-I+1,W(K,I),MDW,W(K,I),MDW) + RN = DDOT(I-1,W(K,1),MDW,W(K,1),MDW) + IF (RN.EQ.0.D0 .AND. SN.GT.SNMAX) THEN + SNMAX = SN + IMAX = K + ELSEIF (K.EQ.I .OR. SN*RNMAX.GT.RN*SNMAX) THEN + SNMAX = SN + RNMAX = RN + IMAX = K + ENDIF + 140 CONTINUE +C +C Interchange rows if necessary. +C + IF (I.NE.IMAX) CALL DSWAP (NP1, W(I,1), MDW, W(IMAX,1), MDW) + IF (SNMAX.GT.RNMAX*TAU**2) THEN +C +C Eliminate elements I+1,...,N in row I. +C + CALL DH12 (1, I, I+1, N, W(I,1), MDW, WS(I), W(I+1,1), MDW, + + 1, M-I) + ELSE + KRANKE = I - 1 + GO TO 160 + ENDIF + 150 CONTINUE +C +C Save diagonal terms of lower trapezoidal matrix. +C + 160 CALL DCOPY (KRANKE, W, MDW+1, WS(KRANKE+1), 1) +C +C Use Householder transformation from left to achieve +C KRANKE by KRANKE upper triangular form. +C + IF (KRANKE.LT.ME) THEN + DO 170 K = KRANKE,1,-1 +C +C Apply transformation to matrix cols. 1,...,K-1. +C + CALL DH12 (1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, + * K-1) +C +C Apply to rt side vector. +C + CALL DH12 (2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, + + 1, 1) + 170 CONTINUE + ENDIF +C +C Solve for variables 1,...,KRANKE in new coordinates. +C + CALL DCOPY (KRANKE, W(1, NP1), 1, X, 1) + DO 180 I = 1,KRANKE + X(I) = (X(I)-DDOT(I-1,W(I,1),MDW,X,1))/W(I,I) + 180 CONTINUE +C +C Compute residuals for reduced problem. +C + MEP1 = ME + 1 + RNORML = 0.D0 + DO 190 I = MEP1,M + W(I,NP1) = W(I,NP1) - DDOT(KRANKE,W(I,1),MDW,X,1) + SN = DDOT(KRANKE,W(I,1),MDW,W(I,1),MDW) + RN = DDOT(N-KRANKE,W(I,KRANKE+1),MDW,W(I,KRANKE+1),MDW) + IF (RN.LE.SN*TAU**2 .AND. KRANKE.LT.N) + * CALL DCOPY (N-KRANKE, 0.D0, 0, W(I,KRANKE+1), MDW) + 190 CONTINUE +C +C Compute equality constraint equations residual length. +C + RNORME = DNRM2(ME-KRANKE,W(KRANKE+1,NP1),1) +C +C Move reduced problem data upward if KRANKE.LT.ME. +C + IF (KRANKE.LT.ME) THEN + DO 200 J = 1,NP1 + CALL DCOPY (M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1) + 200 CONTINUE + ENDIF +C +C Compute solution of reduced problem. +C + CALL DLSI(W(KRANKE+1, KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT, + + X(KRANKE+1), RNORML, MODE, WS(N2), IP(2)) +C +C Test for consistency of equality constraints. +C + IF (ME.GT.0) THEN + MDEQC = 0 + XNRME = DASUM(KRANKE,W(1,NP1),1) + IF (RNORME.GT.TAU*(ENORM*XNRME+FNORM)) MDEQC = 1 + MODE = MODE + MDEQC +C +C Check if solution to equality constraints satisfies inequality +C constraints when there are no degrees of freedom left. +C + IF (KRANKE.EQ.N .AND. MG.GT.0) THEN + XNORM = DASUM(N,X,1) + MAPKE1 = MA + KRANKE + 1 + MEND = MA + KRANKE + MG + DO 210 I = MAPKE1,MEND + SIZE = DASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1)) + IF (W(I,NP1).GT.TAU*SIZE) THEN + MODE = MODE + 2 + GO TO 290 + ENDIF + 210 CONTINUE + ENDIF + ENDIF +C +C Replace diagonal terms of lower trapezoidal matrix. +C + IF (KRANKE.GT.0) THEN + CALL DCOPY (KRANKE, WS(KRANKE+1), 1, W, MDW+1) +C +C Reapply transformation to put solution in original coordinates. +C + DO 220 I = KRANKE,1,-1 + CALL DH12 (2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1) + 220 CONTINUE +C +C Compute covariance matrix of equality constrained problem. +C + IF (COV) THEN + DO 270 J = MIN(KRANKE,N-1),1,-1 + RB = WS(J)*W(J,J) + IF (RB.NE.0.D0) RB = 1.D0/RB + JP1 = J + 1 + DO 230 I = JP1,N + W(I,J) = RB*DDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW) + 230 CONTINUE +C + GAM = 0.5D0*RB*DDOT(N-J,W(JP1,J),1,W(J,JP1),MDW) + CALL DAXPY (N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1) + DO 250 I = JP1,N + DO 240 K = I,N + W(I,K) = W(I,K) + W(J,I)*W(K,J) + W(I,J)*W(J,K) + W(K,I) = W(I,K) + 240 CONTINUE + 250 CONTINUE + UJ = WS(J) + VJ = GAM*UJ + W(J,J) = UJ*VJ + UJ*VJ + DO 260 I = JP1,N + W(J,I) = UJ*W(I,J) + VJ*W(J,I) + 260 CONTINUE + CALL DCOPY (N-J, W(J, JP1), MDW, W(JP1,J), 1) + 270 CONTINUE + ENDIF + ENDIF +C +C Apply the scaling to the covariance matrix. +C + IF (COV) THEN + DO 280 I = 1,N + CALL DSCAL (N, WS(I+N1-1), W(I,1), MDW) + CALL DSCAL (N, WS(I+N1-1), W(1,I), 1) + 280 CONTINUE + ENDIF +C +C Rescale solution vector. +C + 290 IF (MODE.LE.1) THEN + DO 300 J = 1,N + X(J) = X(J)*WS(N1+J-1) + 300 CONTINUE + ENDIF +C + IP(1) = KRANKE + IP(3) = IP(3) + 2*KRANKE + N + RETURN + END +*DECK DLSI + SUBROUTINE DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, + + IP) +C***BEGIN PROLOGUE DLSI +C***SUBSIDIARY +C***PURPOSE Subsidiary to DLSEI +C***LIBRARY SLATEC +C***TYPE REAL(KIND=R8) (LSI-S, DLSI-D) +C***AUTHOR Hanson, R. J., (SNLA) +C***DESCRIPTION +C +C This is a companion subprogram to DLSEI. The documentation for +C DLSEI has complete usage instructions. +C +C Solve.. +C AX = B, A MA by N (least squares equations) +C subject to.. +C +C GX.GE.H, G MG by N (inequality constraints) +C +C Input.. +C +C W(*,*) contains (A B) in rows 1,...,MA+MG, cols 1,...,N+1. +C (G H) +C +C MDW,MA,MG,N +C contain (resp) var. dimension of W(*,*), +C and matrix dimensions. +C +C PRGOPT(*), +C Program option vector. +C +C OUTPUT.. +C +C X(*),RNORM +C +C Solution vector(unless MODE=2), length of AX-B. +C +C MODE +C =0 Inequality constraints are compatible. +C =2 Inequality constraints contradictory. +C +C WS(*), +C Working storage of dimension K+N+(MG+2)*(N+7), +C where K=MAX(MA+MG,N). +C IP(MG+2*N+1) +C Integer working storage +C +C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, +C DLPDP, DSCAL, DSWAP +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and extensively revised (WRB & RWC) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900604 DP version created from SP version. (RWC) +C 920422 Changed CALL to DHFTI to include variable MA. (WRB) +C***END PROLOGUE DLSI + USE REAL_PRECISION + + INTEGER IP(*), MA, MDW, MG, MODE, N + REAL(KIND=R8) PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*) +C + EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, DLPDP, + * DSCAL, DSWAP + REAL(KIND=R8) D1MACH, DASUM, DDOT +C + REAL(KIND=R8) ANORM, DRELPR, FAC, GAM, RB, TAU, TOL, XNORM, + * TMP_NORM(1) + INTEGER I, J, K, KEY, KRANK, KRM1, KRP1, L, LAST, LINK, M, MAP1, + * MDLPDP, MINMAN, N1, N2, N3, NEXT, NP1 + LOGICAL COV, FIRST, SCLCOV +C + SAVE DRELPR, FIRST + DATA FIRST /.TRUE./ +C +C***FIRST EXECUTABLE STATEMENT DLSI +C +C Set the nominal tolerance used in the code. +C + IF (FIRST) DRELPR = D1MACH(4) + FIRST = .FALSE. + TOL = SQRT(DRELPR) +C + MODE = 0 + RNORM = 0.D0 + M = MA + MG + NP1 = N + 1 + KRANK = 0 + IF (N.LE.0 .OR. M.LE.0) GO TO 370 +C +C To process option vector. +C + COV = .FALSE. + SCLCOV = .TRUE. + LAST = 1 + LINK = PRGOPT(1) +C + 100 IF (LINK.GT.1) THEN + KEY = PRGOPT(LAST+1) + IF (KEY.EQ.1) COV = PRGOPT(LAST+2) .NE. 0.D0 + IF (KEY.EQ.10) SCLCOV = PRGOPT(LAST+2) .EQ. 0.D0 + IF (KEY.EQ.5) TOL = MAX(DRELPR,PRGOPT(LAST+2)) + NEXT = PRGOPT(LINK) + LAST = LINK + LINK = NEXT + GO TO 100 + ENDIF +C +C Compute matrix norm of least squares equations. +C + ANORM = 0.D0 + DO 110 J = 1,N + ANORM = MAX(ANORM,DASUM(MA,W(1,J),1)) + 110 CONTINUE +C +C Set tolerance for DHFTI( ) rank test. +C + TAU = TOL*ANORM +C +C Compute Householder orthogonal decomposition of matrix. +C + CALL DCOPY (N, 0.D0, 0, WS, 1) + CALL DCOPY (MA, W(1, NP1), 1, WS, 1) + K = MAX(M,N) + MINMAN = MIN(MA,N) + N1 = K + 1 + N2 = N1 + N + CALL DHFTI (W, MDW, MA, N, WS, MA, 1, TAU, KRANK, TMP_NORM, + + WS(N2), WS(N1), IP) + RNORM = TMP_NORM(1) + FAC = 1.D0 + GAM = MA - KRANK + IF (KRANK.LT.MA .AND. SCLCOV) FAC = RNORM**2/GAM +C +C Reduce to DLPDP and solve. +C + MAP1 = MA + 1 +C +C Compute inequality rt-hand side for DLPDP. +C + IF (MA.LT.M) THEN + IF (MINMAN.GT.0) THEN + DO 120 I = MAP1,M + W(I,NP1) = W(I,NP1) - DDOT(N,W(I,1),MDW,WS,1) + 120 CONTINUE +C +C Apply permutations to col. of inequality constraint matrix. +C + DO 130 I = 1,MINMAN + CALL DSWAP (MG, W(MAP1,I), 1, W(MAP1,IP(I)), 1) + 130 CONTINUE +C +C Apply Householder transformations to constraint matrix. +C + IF (KRANK.GT.0 .AND. KRANK.LT.N) THEN + DO 140 I = KRANK,1,-1 + CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), + + W(MAP1,1), MDW, 1, MG) + 140 CONTINUE + ENDIF +C +C Compute permuted inequality constraint matrix times r-inv. +C + DO 160 I = MAP1,M + DO 150 J = 1,KRANK + W(I,J) = (W(I,J)-DDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J) + 150 CONTINUE + 160 CONTINUE + ENDIF +C +C Solve the reduced problem with DLPDP algorithm, +C the least projected distance problem. +C + CALL DLPDP(W(MAP1,1), MDW, MG, KRANK, N-KRANK, PRGOPT, X, + + XNORM, MDLPDP, WS(N2), IP(N+1)) +C +C Compute solution in original coordinates. +C + IF (MDLPDP.EQ.1) THEN + DO 170 I = KRANK,1,-1 + X(I) = (X(I)-DDOT(KRANK-I,W(I,I+1),MDW,X(I+1),1))/W(I,I) + 170 CONTINUE +C +C Apply Householder transformation to solution vector. +C + IF (KRANK.LT.N) THEN + DO 180 I = 1,KRANK + CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), + + X, 1, 1, 1) + 180 CONTINUE + ENDIF +C +C Repermute variables to their input order. +C + IF (MINMAN.GT.0) THEN + DO 190 I = MINMAN,1,-1 + CALL DSWAP (1, X(I), 1, X(IP(I)), 1) + 190 CONTINUE +C +C Variables are now in original coordinates. +C Add solution of unconstrained problem. +C + DO 200 I = 1,N + X(I) = X(I) + WS(I) + 200 CONTINUE +C +C Compute the residual vector norm. +C + RNORM = SQRT(RNORM**2+XNORM**2) + ENDIF + ELSE + MODE = 2 + ENDIF + ELSE + CALL DCOPY (N, WS, 1, X, 1) + ENDIF +C +C Compute covariance matrix based on the orthogonal decomposition +C from DHFTI( ). +C + IF (.NOT.COV .OR. KRANK.LE.0) GO TO 370 + KRM1 = KRANK - 1 + KRP1 = KRANK + 1 +C +C Copy diagonal terms to working array. +C + CALL DCOPY (KRANK, W, MDW+1, WS(N2), 1) +C +C Reciprocate diagonal terms. +C + DO 210 J = 1,KRANK + W(J,J) = 1.D0/W(J,J) + 210 CONTINUE +C +C Invert the upper triangular QR factor on itself. +C + IF (KRANK.GT.1) THEN + DO 230 I = 1,KRM1 + DO 220 J = I+1,KRANK + W(I,J) = -DDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J) + 220 CONTINUE + 230 CONTINUE + ENDIF +C +C Compute the inverted factor times its transpose. +C + DO 250 I = 1,KRANK + DO 240 J = I,KRANK + W(I,J) = DDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW) + 240 CONTINUE + 250 CONTINUE +C +C Zero out lower trapezoidal part. +C Copy upper triangular to lower triangular part. +C + IF (KRANK.LT.N) THEN + DO 260 J = 1,KRANK + CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) + 260 CONTINUE +C + DO 270 I = KRP1,N + CALL DCOPY (I, 0.D0, 0, W(I,1), MDW) + 270 CONTINUE +C +C Apply right side transformations to lower triangle. +C + N3 = N2 + KRP1 + DO 330 I = 1,KRANK + L = N1 + I + K = N2 + I + RB = WS(L-1)*WS(K-1) +C +C If RB.GE.0.D0, transformation can be regarded as zero. +C + IF (RB.LT.0.D0) THEN + RB = 1.D0/RB +C +C Store unscaled rank one Householder update in work array. +C + CALL DCOPY (N, 0.D0, 0, WS(N3), 1) + L = N1 + I + K = N3 + I + WS(K-1) = WS(L-1) +C + DO 280 J = KRP1,N + WS(N3+J-1) = W(I,J) + 280 CONTINUE +C + DO 290 J = 1,N + WS(J) = RB*(DDOT(J-I,W(J,I),MDW,WS(N3+I-1),1)+ + + DDOT(N-J+1,W(J,J),1,WS(N3+J-1),1)) + 290 CONTINUE +C + L = N3 + I + GAM = 0.5D0*RB*DDOT(N-I+1,WS(L-1),1,WS(I),1) + CALL DAXPY (N-I+1, GAM, WS(L-1), 1, WS(I), 1) + DO 320 J = I,N + DO 300 L = 1,I-1 + W(J,L) = W(J,L) + WS(N3+J-1)*WS(L) + 300 CONTINUE +C + DO 310 L = I,J + W(J,L) = W(J,L) + WS(J)*WS(N3+L-1)+WS(L)*WS(N3+J-1) + 310 CONTINUE + 320 CONTINUE + ENDIF + 330 CONTINUE +C +C Copy lower triangle to upper triangle to symmetrize the +C covariance matrix. +C + DO 340 I = 1,N + CALL DCOPY (I, W(I,1), MDW, W(1,I), 1) + 340 CONTINUE + ENDIF +C +C Repermute rows and columns. +C + DO 350 I = MINMAN,1,-1 + K = IP(I) + IF (I.NE.K) THEN + CALL DSWAP (1, W(I,I), 1, W(K,K), 1) + CALL DSWAP (I-1, W(1,I), 1, W(1,K), 1) + CALL DSWAP (K-I-1, W(I,I+1), MDW, W(I+1,K), 1) + CALL DSWAP (N-K, W(I, K+1), MDW, W(K, K+1), MDW) + ENDIF + 350 CONTINUE +C +C Put in normalized residual sum of squares scale factor +C and symmetrize the resulting covariance matrix. +C + DO 360 J = 1,N + CALL DSCAL (J, FAC, W(1,J), 1) + CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) + 360 CONTINUE +C + 370 IP(1) = KRANK + IP(2) = N + MAX(M,N) + (MG+2)*(N+7) + RETURN + END +*DECK D1MACH + REAL(KIND=R8) FUNCTION D1MACH (I) +C***BEGIN PROLOGUE D1MACH +C***PURPOSE Return floating point machine dependent constants. +C***LIBRARY SLATEC +C***CATEGORY R1 +C***TYPE REAL(KIND=R8) (R1MACH-S, D1MACH-D) +C***KEYWORDS MACHINE CONSTANTS +C***AUTHOR Fox, P. A., (Bell Labs) +C Hall, A. D., (Bell Labs) +C Schryer, N. L., (Bell Labs) +C***DESCRIPTION +C +C D1MACH can be used to obtain machine-dependent parameters for the +C local machine environment. It is a function subprogram with one +C (input) argument, and can be referenced as follows: +C +C D = D1MACH(I) +C +C where I=1,...,5. The (output) value of D above is determined by +C the (input) value of I. The results for various values of I are +C discussed below. +C +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 Assume double precision numbers are represented in the T-digit, +C base-B form +C +C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and +C EMIN .LE. E .LE. EMAX. +C +C The values of B, T, EMIN and EMAX are provided in I1MACH as +C follows: +C I1MACH(10) = B, the base. +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 +C To alter this function for a particular environment, the desired +C set of DATA statements should be activated by removing the C from +C column 1. Also, the values of D1MACH(1) - D1MACH(4) should be +C checked for consistency with the local operating system. +C +C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +C a portable library, ACM Transactions on Mathematical +C Software 4, 2 (June 1978), pp. 177-188. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 890213 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900618 Added DEC RISC constants. (WRB) +C 900723 Added IBM RS 6000 constants. (WRB) +C 900911 Added SUN 386i constants. (WRB) +C 910710 Added HP 730 constants. (SMR) +C 911114 Added Convex IEEE constants. (WRB) +C 920121 Added SUN -r8 compiler option constants. (WRB) +C 920229 Added Touchstone Delta i860 constants. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 920625 Added CONVEX -p8 and -pd8 compiler option constants. +C (BKS, WRB) +C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) +C 010817 Elevated IEEE to highest importance; see next set of +C comments below. (DWL) +C***END PROLOGUE D1MACH +C + USE REAL_PRECISION + + INTEGER SMALL(4) + INTEGER LARGE(4) + INTEGER RIGHT(4) + INTEGER DIVER(4) + INTEGER LOG10(4) +C +C Initial data here correspond to the IEEE standard. The values for +C DMACH(1), DMACH(3) and DMACH(4) are slight upper bounds. The value +C for DMACH(2) is a slight lower bound. The value for DMACH(5) is +C a 20-digit approximation. If one of the sets of initial data below +C is preferred, do the necessary commenting and uncommenting. (DWL) + REAL(KIND=R8) DMACH(5) + DATA DMACH / 2.23D-308, 1.79D+308, 1.111D-16, 2.222D-16, + 1 0.30102999566398119521D0 / + SAVE DMACH +C + 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 AMIGA +C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE APOLLO +C +C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / +C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / +C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / +C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM +C +C DATA SMALL(1) / ZC00800000 / +C DATA SMALL(2) / Z000000000 / +C DATA LARGE(1) / ZDFFFFFFFF / +C DATA LARGE(2) / ZFFFFFFFFF / +C DATA RIGHT(1) / ZCC5800000 / +C DATA RIGHT(2) / Z000000000 / +C DATA DIVER(1) / ZCC6800000 / +C DATA DIVER(2) / Z000000000 / +C DATA LOG10(1) / ZD00E730E7 / +C DATA LOG10(2) / ZC77800DC0 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O0000000000000000 / +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O0007777777777777 / +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O7770000000000000 / +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O7777777777777777 / +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 / +C +C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE +C +C DATA SMALL(1) / Z"3001800000000000" / +C DATA SMALL(2) / Z"3001000000000000" / +C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / +C DATA LARGE(2) / Z"4FFE000000000000" / +C DATA RIGHT(1) / Z"3FD2800000000000" / +C DATA RIGHT(2) / Z"3FD2000000000000" / +C DATA DIVER(1) / Z"3FD3800000000000" / +C DATA DIVER(2) / Z"3FD3000000000000" / +C DATA LOG10(1) / Z"3FFF9A209A84FBCF" / +C DATA LOG10(2) / Z"3FFFF7988F8959AC" / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES +C +C DATA SMALL(1) / 00564000000000000000B / +C DATA SMALL(2) / 00000000000000000000B / +C DATA LARGE(1) / 37757777777777777777B / +C DATA LARGE(2) / 37157777777777777777B / +C DATA RIGHT(1) / 15624000000000000000B / +C DATA RIGHT(2) / 00000000000000000000B / +C DATA DIVER(1) / 15634000000000000000B / +C DATA DIVER(2) / 00000000000000000000B / +C DATA LOG10(1) / 17164642023241175717B / +C DATA LOG10(2) / 16367571421742254654B / +C +C MACHINE CONSTANTS FOR THE CELERITY C1260 +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fn OR -pd8 COMPILER OPTION +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CC0000000000000' / +C DATA DMACH(4) / Z'3CD0000000000000' / +C DATA DMACH(5) / Z'3FF34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fi COMPILER OPTION +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -p8 COMPILER OPTION +C +C DATA DMACH(1) / Z'00010000000000000000000000000000' / +C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3F900000000000000000000000000000' / +C DATA DMACH(4) / Z'3F910000000000000000000000000000' / +C DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / +C +C MACHINE CONSTANTS FOR THE CRAY +C +C DATA SMALL(1) / 201354000000000000000B / +C DATA SMALL(2) / 000000000000000000000B / +C DATA LARGE(1) / 577767777777777777777B / +C DATA LARGE(2) / 000007777777777777774B / +C DATA RIGHT(1) / 376434000000000000000B / +C DATA RIGHT(2) / 000000000000000000000B / +C DATA DIVER(1) / 376444000000000000000B / +C DATA DIVER(2) / 000000000000000000000B / +C DATA LOG10(1) / 377774642023241175717B / +C DATA LOG10(2) / 000007571421742254654B / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - +C STATIC DMACH(5) +C +C DATA SMALL / 20K, 3*0 / +C DATA LARGE / 77777K, 3*177777K / +C DATA RIGHT / 31420K, 3*0 / +C DATA DIVER / 32020K, 3*0 / +C DATA LOG10 / 40423K, 42023K, 50237K, 74776K / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING G_FLOAT +C +C DATA DMACH(1) / '0000000000000010'X / +C DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / +C DATA DMACH(3) / '0000000000003CC0'X / +C DATA DMACH(4) / '0000000000003CD0'X / +C DATA DMACH(5) / '79FF509F44133FF3'X / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING IEEE_FORMAT +C +C DATA DMACH(1) / '0010000000000000'X / +C DATA DMACH(2) / '7FEFFFFFFFFFFFFF'X / +C DATA DMACH(3) / '3CA0000000000000'X / +C DATA DMACH(4) / '3CB0000000000000'X / +C DATA DMACH(5) / '3FD34413509F79FF'X / +C +C MACHINE CONSTANTS FOR THE DEC RISC +C +C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ +C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ +C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ +C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ +C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING D_FLOATING +C (EXPRESSED IN INTEGER AND HEXADECIMAL) +C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS +C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS +C +C DATA SMALL(1), SMALL(2) / 128, 0 / +C DATA LARGE(1), LARGE(2) / -32769, -1 / +C DATA RIGHT(1), RIGHT(2) / 9344, 0 / +C DATA DIVER(1), DIVER(2) / 9472, 0 / +C DATA LOG10(1), LOG10(2) / 546979738, -805796613 / +C +C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / +C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING G_FLOATING +C (EXPRESSED IN INTEGER AND HEXADECIMAL) +C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS +C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS +C +C DATA SMALL(1), SMALL(2) / 16, 0 / +C DATA LARGE(1), LARGE(2) / -32769, -1 / +C DATA RIGHT(1), RIGHT(2) / 15552, 0 / +C DATA DIVER(1), DIVER(2) / 15568, 0 / +C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / +C +C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / +C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / +C +C MACHINE CONSTANTS FOR THE ELXSI 6400 +C (ASSUMING REAL*8 IS THE DEFAULT REAL(KIND=R8)) +C +C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / +C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / +C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / +C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / +C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / +C +C MACHINE CONSTANTS FOR THE HARRIS 220 +C +C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / +C DATA LARGE(1), LARGE(2) / '37777777, '37777577 / +C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / +C DATA DIVER(1), DIVER(2) / '20000000, '00000334 / +C DATA LOG10(1), LOG10(2) / '23210115, '10237777 / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES +C +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 / +C +C MACHINE CONSTANTS FOR THE HP 730 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C THREE WORD REAL(KIND=R8) OPTION WITH FTN4 +C +C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / +C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / +C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / +C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / +C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C FOUR WORD REAL(KIND=R8) OPTION WITH FTN4 +C +C DATA SMALL(1), SMALL(2) / 40000B, 0 / +C DATA SMALL(3), SMALL(4) / 0, 1 / +C DATA LARGE(1), LARGE(2) / 77777B, 177777B / +C DATA LARGE(3), LARGE(4) / 177777B, 177776B / +C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / +C DATA RIGHT(3), RIGHT(4) / 0, 225B / +C DATA DIVER(1), DIVER(2) / 40000B, 0 / +C DATA DIVER(3), DIVER(4) / 0, 227B / +C DATA LOG10(1), LOG10(2) / 46420B, 46502B / +C DATA LOG10(3), LOG10(4) / 76747B, 176377B / +C +C MACHINE CONSTANTS FOR THE HP 9000 +C +C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / +C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / +C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / +C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / +C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND +C THE PERKIN ELMER (INTERDATA) 7/32. +C +C DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / +C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / +C +C MACHINE CONSTANTS FOR THE IBM PC +C ASSUMES THAT ALL ARITHMETIC IS DONE IN REAL(KIND=R8) +C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. +C +C DATA SMALL(1) / 2.23D-308 / +C DATA LARGE(1) / 1.79D+308 / +C DATA RIGHT(1) / 1.11D-16 / +C DATA DIVER(1) / 2.22D-16 / +C DATA LOG10(1) / 0.301029995663981195D0 / +C +C MACHINE CONSTANTS FOR THE IBM RS 6000 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE INTEL i860 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) +C +C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / +C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / +C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / +C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / +C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) +C +C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / +C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / +C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / +C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / +C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +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 / +C +C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / +C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / +C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / +C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / +C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA SMALL(1), SMALL(2) / 128, 0 / +C DATA SMALL(3), SMALL(4) / 0, 0 / +C DATA LARGE(1), LARGE(2) / 32767, -1 / +C DATA LARGE(3), LARGE(4) / -1, -1 / +C DATA RIGHT(1), RIGHT(2) / 9344, 0 / +C DATA RIGHT(3), RIGHT(4) / 0, 0 / +C DATA DIVER(1), DIVER(2) / 9472, 0 / +C DATA DIVER(3), DIVER(4) / 0, 0 / +C DATA LOG10(1), LOG10(2) / 16282, 8346 / +C DATA LOG10(3), LOG10(4) / -31493, -12296 / +C +C DATA SMALL(1), SMALL(2) / O000200, O000000 / +C DATA SMALL(3), SMALL(4) / O000000, O000000 / +C DATA LARGE(1), LARGE(2) / O077777, O177777 / +C DATA LARGE(3), LARGE(4) / O177777, O177777 / +C DATA RIGHT(1), RIGHT(2) / O022200, O000000 / +C DATA RIGHT(3), RIGHT(4) / O000000, O000000 / +C DATA DIVER(1), DIVER(2) / O022400, O000000 / +C DATA DIVER(3), DIVER(4) / O000000, O000000 / +C DATA LOG10(1), LOG10(2) / O037632, O020232 / +C DATA LOG10(3), LOG10(4) / O102373, O147770 / +C +C MACHINE CONSTANTS FOR THE SILICON GRAPHICS +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE SUN +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE SUN +C USING THE -r8 COMPILER OPTION +C +C DATA DMACH(1) / Z'00010000000000000000000000000000' / +C DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / +C DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / +C DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / +C +C MACHINE CONSTANTS FOR THE SUN 386i +C +C DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / +C DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / +C DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' +C DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER +C +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 / +C +C***FIRST EXECUTABLE STATEMENT D1MACH +C IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'D1MACH', +C + 'I OUT OF BOUNDS', 1, 2) +C + D1MACH = DMACH(I) + RETURN +C + END +*DECK I1MACH + INTEGER FUNCTION I1MACH (I) +C***BEGIN PROLOGUE I1MACH +C***PURPOSE Return integer machine dependent constants. +C***LIBRARY SLATEC +C***CATEGORY R1 +C***TYPE INTEGER (I1MACH-I) +C***KEYWORDS MACHINE CONSTANTS +C***AUTHOR Fox, P. A., (Bell Labs) +C Hall, A. D., (Bell Labs) +C Schryer, N. L., (Bell Labs) +C***DESCRIPTION +C +C I1MACH can be used to obtain machine-dependent parameters for the +C local machine environment. It is a function subprogram with one +C (input) argument and can be referenced as follows: +C +C K = I1MACH(I) +C +C where I=1,...,16. The (output) value of K above is determined by +C the (input) value of I. The results for various values of I are +C discussed below. +C +C I/O unit numbers: +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 +C Words: +C I1MACH( 5) = the number of bits per integer storage unit. +C I1MACH( 6) = the number of characters per integer storage unit. +C +C Integers: +C assume integers are represented in the S-digit, base-A form +C +C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) +C +C where 0 .LE. X(I) .LT. A for I=0,...,S-1. +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 +C Floating-Point Numbers: +C Assume floating-point numbers are represented in the T-digit, +C base-B form +C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C where 0 .LE. X(I) .LT. B for I=1,...,T, +C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. +C I1MACH(10) = B, the base. +C +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 +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 +C To alter this function for a particular environment, the desired +C set of DATA statements should be activated by removing the C from +C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be +C checked for consistency with the local operating system. +C +C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +C a portable library, ACM Transactions on Mathematical +C Software 4, 2 (June 1978), pp. 177-188. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 891012 Added VAX G-floating constants. (WRB) +C 891012 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900618 Added DEC RISC constants. (WRB) +C 900723 Added IBM RS 6000 constants. (WRB) +C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. +C (RWC) +C 910710 Added HP 730 constants. (SMR) +C 911114 Added Convex IEEE constants. (WRB) +C 920121 Added SUN -r8 compiler option constants. (WRB) +C 920229 Added Touchstone Delta i860 constants. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 920625 Added Convex -p8 and -pd8 compiler option constants. +C (BKS, WRB) +C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) +C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler +C options. (DWL, RWC and WRB). +C 010817 Elevated IEEE to highest importance; see next set of +C comments below. (DWL) +C***END PROLOGUE I1MACH +C +C Initial data here correspond to the IEEE standard. If one of the +C sets of initial data below is preferred, do the necessary commenting +C and uncommenting. (DWL) + INTEGER IMACH(16),OUTPUT + DATA IMACH( 1) / 5 / + DATA IMACH( 2) / 6 / + DATA IMACH( 3) / 6 / + DATA IMACH( 4) / 6 / + DATA IMACH( 5) / 32 / + DATA IMACH( 6) / 4 / + DATA IMACH( 7) / 2 / + DATA IMACH( 8) / 31 / + DATA IMACH( 9) / 2147483647 / + DATA IMACH(10) / 2 / + DATA IMACH(11) / 24 / + DATA IMACH(12) / -126 / + DATA IMACH(13) / 127 / + DATA IMACH(14) / 53 / + DATA IMACH(15) / -1022 / + DATA IMACH(16) / 1023 / + SAVE IMACH + EQUIVALENCE (IMACH(4),OUTPUT) +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT COMPILER +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE APOLLO +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 129 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1025 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM +C +C DATA IMACH( 1) / 7 / +C DATA IMACH( 2) / 2 / +C DATA IMACH( 3) / 2 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 33 / +C DATA IMACH( 9) / Z1FFFFFFFF / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -256 / +C DATA IMACH(13) / 255 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) / -256 / +C DATA IMACH(16) / 255 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM +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) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -50 / +C DATA IMACH(16) / 76 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS +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) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -32754 / +C DATA IMACH(16) / 32780 / +C +C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE +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) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -4095 / +C DATA IMACH(13) / 4094 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -4095 / +C DATA IMACH(16) / 4094 / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6LOUTPUT/ +C DATA IMACH( 5) / 60 / +C DATA IMACH( 6) / 10 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 48 / +C DATA IMACH( 9) / 00007777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -929 / +C DATA IMACH(13) / 1070 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -929 / +C DATA IMACH(16) / 1069 / +C +C MACHINE CONSTANTS FOR THE CELERITY C1260 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 0 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / Z'7FFFFFFF' / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fn COMPILER OPTION +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) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fi COMPILER OPTION +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -p8 COMPILER OPTION +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) / 64 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1023 / +C DATA IMACH(13) / 1023 / +C DATA IMACH(14) / 113 / +C DATA IMACH(15) / -16383 / +C DATA IMACH(16) / 16383 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -pd8 COMPILER OPTION +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) / 64 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1023 / +C DATA IMACH(13) / 1023 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CRAY +C USING THE 46 BIT INTEGER COMPILER OPTION +C +C DATA IMACH( 1) / 100 / +C DATA IMACH( 2) / 101 / +C DATA IMACH( 3) / 102 / +C DATA IMACH( 4) / 101 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 46 / +C DATA IMACH( 9) / 1777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -8189 / +C DATA IMACH(13) / 8190 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -8099 / +C DATA IMACH(16) / 8190 / +C +C MACHINE CONSTANTS FOR THE CRAY +C USING THE 64 BIT INTEGER COMPILER OPTION +C +C DATA IMACH( 1) / 100 / +C DATA IMACH( 2) / 101 / +C DATA IMACH( 3) / 102 / +C DATA IMACH( 4) / 101 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 777777777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -8189 / +C DATA IMACH(13) / 8190 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -8099 / +C DATA IMACH(16) / 8190 / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C +C DATA IMACH( 1) / 11 / +C DATA IMACH( 2) / 12 / +C DATA IMACH( 3) / 8 / +C DATA IMACH( 4) / 10 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING G_FLOAT +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING IEEE_FLOAT +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE DEC RISC +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING D_FLOATING +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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 / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING G_FLOATING +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE ELXSI 6400 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 32 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE HARRIS 220 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / 3 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 23 / +C DATA IMACH( 9) / 8388607 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 38 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 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) / 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) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 63 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 730 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C 3 WORD REAL(KIND=R8) OPTION WITH FTN4 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 4 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 39 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C 4 WORD REAL(KIND=R8) OPTION WITH FTN4 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 4 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 55 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 9000 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 7 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 32 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1015 / +C DATA IMACH(16) / 1017 / +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND +C THE PERKIN ELMER (INTERDATA) 7/32. +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) / Z7FFFFFFF / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 / +C +C MACHINE CONSTANTS FOR THE IBM PC +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 0 / +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) / -125 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE IBM RS 6000 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 0 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE INTEL i860 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 54 / +C DATA IMACH(15) / -101 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 62 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +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 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 16-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +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 / +C +C MACHINE CONSTANTS FOR THE SILICON GRAPHICS +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE SUN +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE SUN +C USING THE -r8 COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +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) / 53 / +C DATA IMACH(12) / -1021 / +C DATA IMACH(13) / 1024 / +C DATA IMACH(14) / 113 / +C DATA IMACH(15) / -16381 / +C DATA IMACH(16) / 16384 / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 1 / +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) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) / -1024 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR +C +C DATA IMACH( 1) / 1 / +C DATA IMACH( 2) / 1 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +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 / +C +C***FIRST EXECUTABLE STATEMENT I1MACH + IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 +C + I1MACH = IMACH(I) + RETURN +C + 10 CONTINUE + WRITE (UNIT = OUTPUT, FMT = 9000) + 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') +C +C CALL FDUMP +C + STOP + END +*DECK DH12 + SUBROUTINE DH12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV, + + NCV) +C***BEGIN PROLOGUE DH12 +C***SUBSIDIARY +C***PURPOSE Subsidiary to DHFTI, DLSEI and DWNNLS +C***LIBRARY SLATEC +C***TYPE REAL(KIND=R8) (H12-S, DH12-D) +C***AUTHOR (UNKNOWN) +C***DESCRIPTION +C +C *** REAL(KIND=R8) VERSION OF H12 ****** +C +C C.L.Lawson and R.J.Hanson, Jet Propulsion Laboratory, 1973 Jun 12 +C to appear in 'Solving Least Squares Problems', Prentice-Hall, 1974 +C +C Construction and/or application of a single +C Householder transformation.. Q = I + U*(U**T)/B +C +C MODE = 1 or 2 to select algorithm H1 or H2 . +C LPIVOT is the index of the pivot element. +C L1,M If L1 .LE. M the transformation will be constructed to +C zero elements indexed from L1 through M. If L1 GT. M +C THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. +C U(),IUE,UP On entry to H1 U() contains the pivot vector. +C IUE is the storage increment between elements. +C On exit from H1 U() and UP +C contain quantities defining the vector U of the +C Householder transformation. On entry to H2 U() +C and UP should contain quantities previously computed +C by H1. These will not be modified by H2. +C C() On entry to H1 or H2 C() contains a matrix which will be +C regarded as a set of vectors to which the Householder +C transformation is to be applied. On exit C() contains the +C set of transformed vectors. +C ICE Storage increment between elements of vectors in C(). +C ICV Storage increment between vectors in C(). +C NCV Number of vectors in C() to be transformed. If NCV .LE. 0 +C no operations will be done on C(). +C +C***SEE ALSO DHFTI, DLSEI, DWNNLS +C***ROUTINES CALLED DAXPY, DDOT, DSWAP +C***REVISION HISTORY (YYMMDD) +C 790101 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900911 Added DDOT to REAL(KIND=R8) statement. (WRB) +C***END PROLOGUE DH12 + USE REAL_PRECISION + + INTEGER I, I2, I3, I4, ICE, ICV, INCR, IUE, J, KL1, KL2, KLP, + * L1, L1M1, LPIVOT, M, MML1P2, MODE, NCV + REAL(KIND=R8) B, C, CL, CLINV, ONE, UL1M1, SM, U, UP, DDOT + DIMENSION U(IUE,*), C(*) +C BEGIN BLOCK PERMITTING ...EXITS TO 140 +C***FIRST EXECUTABLE STATEMENT DH12 + ONE = 1.0D0 +C +C ...EXIT + IF (0 .GE. LPIVOT .OR. LPIVOT .GE. L1 .OR. L1 .GT. M) GO TO 140 + CL = ABS(U(1,LPIVOT)) + IF (MODE .EQ. 2) GO TO 40 +C ****** CONSTRUCT THE TRANSFORMATION. ****** + DO 10 J = L1, M + CL = MAX(ABS(U(1,J)),CL) + 10 CONTINUE + IF (CL .GT. 0.0D0) GO TO 20 +C .........EXIT + GO TO 140 + 20 CONTINUE + CLINV = ONE/CL + SM = (U(1,LPIVOT)*CLINV)**2 + DO 30 J = L1, M + SM = SM + (U(1,J)*CLINV)**2 + 30 CONTINUE + CL = CL*SQRT(SM) + IF (U(1,LPIVOT) .GT. 0.0D0) CL = -CL + UP = U(1,LPIVOT) - CL + U(1,LPIVOT) = CL + GO TO 50 + 40 CONTINUE +C ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** +C + IF (CL .GT. 0.0D0) GO TO 50 +C ......EXIT + GO TO 140 + 50 CONTINUE +C ...EXIT + IF (NCV .LE. 0) GO TO 140 + B = UP*U(1,LPIVOT) +C B MUST BE NONPOSITIVE HERE. IF B = 0., RETURN. +C + IF (B .LT. 0.0D0) GO TO 60 +C ......EXIT + GO TO 140 + 60 CONTINUE + B = ONE/B + MML1P2 = M - L1 + 2 + IF (MML1P2 .LE. 20) GO TO 80 + L1M1 = L1 - 1 + KL1 = 1 + (L1M1 - 1)*ICE + KL2 = KL1 + KLP = 1 + (LPIVOT - 1)*ICE + UL1M1 = U(1,L1M1) + U(1,L1M1) = UP + IF (LPIVOT .NE. L1M1) CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) + DO 70 J = 1, NCV + SM = DDOT(MML1P2,U(1,L1M1),IUE,C(KL1),ICE) + SM = SM*B + CALL DAXPY(MML1P2,SM,U(1,L1M1),IUE,C(KL1),ICE) + KL1 = KL1 + ICV + 70 CONTINUE + U(1,L1M1) = UL1M1 +C ......EXIT + IF (LPIVOT .EQ. L1M1) GO TO 140 + KL1 = KL2 + CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) + GO TO 130 + 80 CONTINUE + I2 = 1 - ICV + ICE*(LPIVOT - 1) + INCR = ICE*(L1 - LPIVOT) + DO 120 J = 1, NCV + I2 = I2 + ICV + I3 = I2 + INCR + I4 = I3 + SM = C(I2)*UP + DO 90 I = L1, M + SM = SM + C(I3)*U(1,I) + I3 = I3 + ICE + 90 CONTINUE + IF (SM .EQ. 0.0D0) GO TO 110 + SM = SM*B + C(I2) = C(I2) + SM*UP + DO 100 I = L1, M + C(I4) = C(I4) + SM*U(1,I) + I4 = I4 + ICE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + RETURN + END +*DECK DHFTI + SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, + + G, IP) +C***BEGIN PROLOGUE DHFTI +C***PURPOSE Solve a least squares problem for banded matrices using +C sequential accumulation of rows of the data matrix. +C Exactly one right-hand side vector is permitted. +C***LIBRARY SLATEC +C***CATEGORY D9 +C***TYPE REAL(KIND=R8) (HFTI-S, DHFTI-D) +C***KEYWORDS CURVE FITTING, LEAST SQUARES +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C***DESCRIPTION +C +C DIMENSION A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N) +C +C This subroutine solves a linear least squares problem or a set of +C linear least squares problems having the same matrix but different +C right-side vectors. The problem data consists of an M by N matrix +C A, an M by NB matrix B, and an absolute tolerance parameter TAU +C whose usage is described below. The NB column vectors of B +C represent right-side vectors for NB distinct linear least squares +C problems. +C +C This set of problems can also be written as the matrix least +C squares problem +C +C AX = B, +C +C where X is the N by NB solution matrix. +C +C Note that if B is the M by M identity matrix, then X will be the +C pseudo-inverse of A. +C +C This subroutine first transforms the augmented matrix (A B) to a +C matrix (R C) using premultiplying Householder transformations with +C column interchanges. All subdiagonal elements in the matrix R are +C zero and its diagonal elements satisfy +C +C ABS(R(I,I)).GE.ABS(R(I+1,I+1)), +C +C I = 1,...,L-1, where +C +C L = MIN(M,N). +C +C The subroutine will compute an integer, KRANK, equal to the number +C of diagonal terms of R that exceed TAU in magnitude. Then a +C solution of minimum Euclidean length is computed using the first +C KRANK rows of (R C). +C +C To be specific we suggest that the user consider an easily +C computable matrix norm, such as, the maximum of all column sums of +C magnitudes. +C +C Now if the relative uncertainty of B is EPS, (norm of uncertainty/ +C norm of B), it is suggested that TAU be set approximately equal to +C EPS*(norm of A). +C +C The user must dimension all arrays appearing in the call list.. +C A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N). This +C permits the solution of a range of problems in the same array +C space. +C +C The entire set of parameters for DHFTI are +C +C INPUT.. All TYPE REAL variables are REAL(KIND=R8) +C +C A(*,*),MDA,M,N The array A(*,*) initially contains the M by N +C matrix A of the least squares problem AX = B. +C The first dimensioning parameter of the array +C A(*,*) is MDA, which must satisfy MDA.GE.M +C Either M.GE.N or M.LT.N is permitted. There +C is no restriction on the rank of A. The +C condition MDA.LT.M is considered an error. +C +C B(*),MDB,NB If NB = 0 the subroutine will perform the +C orthogonal decomposition but will make no +C references to the array B(*). If NB.GT.0 +C the array B(*) must initially contain the M by +C NB matrix B of the least squares problem AX = +C B. If NB.GE.2 the array B(*) must be doubly +C subscripted with first dimensioning parameter +C MDB.GE.MAX(M,N). If NB = 1 the array B(*) may +C be either doubly or singly subscripted. In +C the latter case the value of MDB is arbitrary +C but it should be set to some valid integer +C value such as MDB = M. +C +C The condition of NB.GT.1.AND.MDB.LT. MAX(M,N) +C is considered an error. +C +C TAU Absolute tolerance parameter provided by user +C for pseudorank determination. +C +C H(*),G(*),IP(*) Arrays of working space used by DHFTI. +C +C OUTPUT.. All TYPE REAL variables are REAL(KIND=R8) +C +C A(*,*) The contents of the array A(*,*) will be +C modified by the subroutine. These contents +C are not generally required by the user. +C +C B(*) On return the array B(*) will contain the N by +C NB solution matrix X. +C +C KRANK Set by the subroutine to indicate the +C pseudorank of A. +C +C RNORM(*) On return, RNORM(J) will contain the Euclidean +C norm of the residual vector for the problem +C defined by the J-th column vector of the array +C B(*,*) for J = 1,...,NB. +C +C H(*),G(*) On return these arrays respectively contain +C elements of the pre- and post-multiplying +C Householder transformations used to compute +C the minimum Euclidean length solution. +C +C IP(*) Array in which the subroutine records indices +C describing the permutation of column vectors. +C The contents of arrays H(*),G(*) and IP(*) +C are not generally required by the user. +C +C***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares +C Problems, Prentice-Hall, Inc., 1974, Chapter 14. +C***ROUTINES CALLED D1MACH, DH12, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790101 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 891006 Cosmetic changes to prologue. (WRB) +C 891006 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 901005 Replace usage of DDIFF with usage of D1MACH. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DHFTI + USE REAL_PRECISION + + INTEGER I, II, IOPT, IP(*), IP1, J, JB, JJ, K, KP1, KRANK, L, + * LDIAG, LMAX, M, MDA, MDB, N, NB, NERR + REAL(KIND=R8) A, B, D1MACH, DZERO, FACTOR, + * G, H, HMAX, RELEPS, RNORM, SM, SM1, SZERO, TAU, TMP + DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*) + SAVE RELEPS + DATA RELEPS /0.D0/ +C BEGIN BLOCK PERMITTING ...EXITS TO 360 +C***FIRST EXECUTABLE STATEMENT DHFTI + IF (RELEPS.EQ.0.D0) RELEPS = D1MACH(4) + SZERO = 0.0D0 + DZERO = 0.0D0 + FACTOR = 0.001D0 +C + K = 0 + LDIAG = MIN(M,N) + IF (LDIAG .LE. 0) GO TO 350 +C BEGIN BLOCK PERMITTING ...EXITS TO 130 +C BEGIN BLOCK PERMITTING ...EXITS TO 120 + IF (MDA .GE. M) GO TO 10 + NERR = 1 + IOPT = 2 +C CALL XERMSG ('SLATEC', 'DHFTI', +C + 'MDA.LT.M, PROBABLE ERROR.', +C + NERR, IOPT) +C ...............EXIT + GO TO 360 + 10 CONTINUE +C + IF (NB .LE. 1 .OR. MAX(M,N) .LE. MDB) GO TO 20 + NERR = 2 + IOPT = 2 +C CALL XERMSG ('SLATEC', 'DHFTI', +C + 'MDB.LT.MAX(M,N).AND.NB.GT.1. PROBABLE ERROR.', +C + NERR, IOPT) +C ...............EXIT + GO TO 360 + 20 CONTINUE +C + DO 100 J = 1, LDIAG +C BEGIN BLOCK PERMITTING ...EXITS TO 70 + IF (J .EQ. 1) GO TO 40 +C +C UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX +C .. + LMAX = J + DO 30 L = J, N + H(L) = H(L) - A(J-1,L)**2 + IF (H(L) .GT. H(LMAX)) LMAX = L + 30 CONTINUE +C ......EXIT + IF (FACTOR*H(LMAX) .GT. HMAX*RELEPS) GO TO 70 + 40 CONTINUE +C +C COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX +C .. + LMAX = J + DO 60 L = J, N + H(L) = 0.0D0 + DO 50 I = J, M + H(L) = H(L) + A(I,L)**2 + 50 CONTINUE + IF (H(L) .GT. H(LMAX)) LMAX = L + 60 CONTINUE + HMAX = H(LMAX) + 70 CONTINUE +C .. +C LMAX HAS BEEN DETERMINED +C +C DO COLUMN INTERCHANGES IF NEEDED. +C .. + IP(J) = LMAX + IF (IP(J) .EQ. J) GO TO 90 + DO 80 I = 1, M + TMP = A(I,J) + A(I,J) = A(I,LMAX) + A(I,LMAX) = TMP + 80 CONTINUE + H(LMAX) = H(J) + 90 CONTINUE +C +C COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A +C AND B. +C .. + CALL DH12(1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA, + * N-J) + CALL DH12(2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB) + 100 CONTINUE +C +C DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, +C TAU. +C .. + DO 110 J = 1, LDIAG +C ......EXIT + IF (ABS(A(J,J)) .LE. TAU) GO TO 120 + 110 CONTINUE + K = LDIAG +C ......EXIT + GO TO 130 + 120 CONTINUE + K = J - 1 + 130 CONTINUE + KP1 = K + 1 +C +C COMPUTE THE NORMS OF THE RESIDUAL VECTORS. +C + IF (NB .LT. 1) GO TO 170 + DO 160 JB = 1, NB + TMP = SZERO + IF (M .LT. KP1) GO TO 150 + DO 140 I = KP1, M + TMP = TMP + B(I,JB)**2 + 140 CONTINUE + 150 CONTINUE + RNORM(JB) = SQRT(TMP) + 160 CONTINUE + 170 CONTINUE +C SPECIAL FOR PSEUDORANK = 0 + IF (K .GT. 0) GO TO 210 + IF (NB .LT. 1) GO TO 200 + DO 190 JB = 1, NB + DO 180 I = 1, N + B(I,JB) = SZERO + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + GO TO 340 + 210 CONTINUE +C +C IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER +C DECOMPOSITION OF FIRST K ROWS. +C .. + IF (K .EQ. N) GO TO 230 + DO 220 II = 1, K + I = KP1 - II + CALL DH12(1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1) + 220 CONTINUE + 230 CONTINUE +C +C + IF (NB .LT. 1) GO TO 330 + DO 320 JB = 1, NB +C +C SOLVE THE K BY K TRIANGULAR SYSTEM. +C .. + DO 260 L = 1, K + SM = DZERO + I = KP1 - L + IP1 = I + 1 + IF (K .LT. IP1) GO TO 250 + DO 240 J = IP1, K + SM = SM + A(I,J)*B(J,JB) + 240 CONTINUE + 250 CONTINUE + SM1 = SM + B(I,JB) = (B(I,JB) - SM1)/A(I,I) + 260 CONTINUE +C +C COMPLETE COMPUTATION OF SOLUTION VECTOR. +C .. + IF (K .EQ. N) GO TO 290 + DO 270 J = KP1, N + B(J,JB) = SZERO + 270 CONTINUE + DO 280 I = 1, K + CALL DH12(2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1, + * MDB,1) + 280 CONTINUE + 290 CONTINUE +C +C RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE +C COLUMN INTERCHANGES. +C .. + DO 310 JJ = 1, LDIAG + J = LDIAG + 1 - JJ + IF (IP(J) .EQ. J) GO TO 300 + L = IP(J) + TMP = B(L,JB) + B(L,JB) = B(J,JB) + B(J,JB) = TMP + 300 CONTINUE + 310 CONTINUE + 320 CONTINUE + 330 CONTINUE + 340 CONTINUE + 350 CONTINUE +C .. +C THE SOLUTION VECTORS, X, ARE NOW +C IN THE FIRST N ROWS OF THE ARRAY B(,). +C + KRANK = K + 360 CONTINUE + RETURN + END +*DECK DLPDP + SUBROUTINE DLPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, + + IS) +C***BEGIN PROLOGUE DLPDP +C***SUBSIDIARY +C***PURPOSE Subsidiary to DLSEI +C***LIBRARY SLATEC +C***TYPE REAL(KIND=R8) (LPDP-S, DLPDP-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C **** Double Precision version of LPDP **** +C DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1), +C where N=N1+N2. This is a slight overestimate for WS(*). +C +C Determine an N1-vector W, and +C an N2-vector Z +C which minimizes the Euclidean length of W +C subject to G*W+H*Z .GE. Y. +C This is the least projected distance problem, LPDP. +C The matrices G and H are of respective +C dimensions M by N1 and M by N2. +C +C Called by subprogram DLSI( ). +C +C The matrix +C (G H Y) +C +C occupies rows 1,...,M and cols 1,...,N1+N2+1 of A(*,*). +C +C The solution (W) is returned in X(*). +C (Z) +C +C The value of MODE indicates the status of +C the computation after returning to the user. +C +C MODE=1 The solution was successfully obtained. +C +C MODE=2 The inequalities are inconsistent. +C +C***SEE ALSO DLSEI +C***ROUTINES CALLED DCOPY, DDOT, DNRM2, DSCAL, DWNNLS +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910408 Updated the AUTHOR section. (WRB) +C***END PROLOGUE DLPDP + USE REAL_PRECISION + +C + INTEGER I, IS(*), IW, IX, J, L, M, MDA, MODE, MODEW, N, N1, N2, + * NP1 + REAL(KIND=R8) A(MDA,*), DDOT, DNRM2, FAC, ONE, + * PRGOPT(*), RNORM, SC, WNORM, WS(*), X(*), YNORM, ZERO + SAVE ZERO, ONE, FAC + DATA ZERO,ONE /0.0D0,1.0D0/, FAC /0.1D0/ +C***FIRST EXECUTABLE STATEMENT DLPDP + N = N1 + N2 + MODE = 1 + IF (M .GT. 0) GO TO 20 + IF (N .LE. 0) GO TO 10 + X(1) = ZERO + CALL DCOPY(N,X,0,X,1) + 10 CONTINUE + WNORM = ZERO + GO TO 200 + 20 CONTINUE +C BEGIN BLOCK PERMITTING ...EXITS TO 190 + NP1 = N + 1 +C +C SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE. + DO 40 I = 1, M + SC = DNRM2(N,A(I,1),MDA) + IF (SC .EQ. ZERO) GO TO 30 + SC = ONE/SC + CALL DSCAL(NP1,SC,A(I,1),MDA) + 30 CONTINUE + 40 CONTINUE +C +C SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO). + YNORM = DNRM2(M,A(1,NP1),1) + IF (YNORM .EQ. ZERO) GO TO 50 + SC = ONE/YNORM + CALL DSCAL(M,SC,A(1,NP1),1) + 50 CONTINUE +C +C SCALE COLS OF MATRIX H. + J = N1 + 1 + 60 IF (J .GT. N) GO TO 70 + SC = DNRM2(M,A(1,J),1) + IF (SC .NE. ZERO) SC = ONE/SC + CALL DSCAL(M,SC,A(1,J),1) + X(J) = SC + J = J + 1 + GO TO 60 + 70 CONTINUE + IF (N1 .LE. 0) GO TO 130 +C +C COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*). + IW = 0 + DO 80 I = 1, M +C +C MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY. + CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) + IW = IW + N2 +C +C MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY. + CALL DCOPY(N1,A(I,1),MDA,WS(IW+1),1) + IW = IW + N1 +C +C MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY. + WS(IW+1) = A(I,NP1) + IW = IW + 1 + 80 CONTINUE + WS(IW+1) = ZERO + CALL DCOPY(N,WS(IW+1),0,WS(IW+1),1) + IW = IW + N + WS(IW+1) = ONE + IW = IW + 1 +C +C SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0. THE +C MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR +C F = TRANSPOSE OF (0,...,0,1). + IX = IW + 1 + IW = IW + M +C +C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF +C DWNNLS( ). + IS(1) = 0 + IS(2) = 0 + CALL DWNNLS(WS,NP1,N2,NP1-N2,M,0,PRGOPT,WS(IX),RNORM, + * MODEW,IS,WS(IW+1)) +C +C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W. + SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) + IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) + * GO TO 110 + SC = ONE/SC + DO 90 J = 1, N1 + X(J) = SC*DDOT(M,A(1,J),1,WS(IX),1) + 90 CONTINUE +C +C COMPUTE THE VECTOR Q=Y-GW. OVERWRITE Y WITH THIS +C VECTOR. + DO 100 I = 1, M + A(I,NP1) = A(I,NP1) - DDOT(N1,A(I,1),MDA,X,1) + 100 CONTINUE + GO TO 120 + 110 CONTINUE + MODE = 2 +C .........EXIT + GO TO 190 + 120 CONTINUE + 130 CONTINUE + IF (N2 .LE. 0) GO TO 180 +C +C COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*). + IW = 0 + DO 140 I = 1, M + CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) + IW = IW + N2 + WS(IW+1) = A(I,NP1) + IW = IW + 1 + 140 CONTINUE + WS(IW+1) = ZERO + CALL DCOPY(N2,WS(IW+1),0,WS(IW+1),1) + IW = IW + N2 + WS(IW+1) = ONE + IW = IW + 1 + IX = IW + 1 + IW = IW + M +C +C SOLVE RV=S SUBJECT TO V.GE.0. THE MATRIX R =(TRANSPOSE +C OF (H Q)), WHERE Q=Y-GW. THE (N2+1)-VECTOR S =(TRANSPOSE +C OF (0,...,0,1)). +C +C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF +C DWNNLS( ). + IS(1) = 0 + IS(2) = 0 + CALL DWNNLS(WS,N2+1,0,N2+1,M,0,PRGOPT,WS(IX),RNORM,MODEW, + * IS,WS(IW+1)) +C +C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z. + SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) + IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) + * GO TO 160 + SC = ONE/SC + DO 150 J = 1, N2 + L = N1 + J + X(L) = SC*DDOT(M,A(1,L),1,WS(IX),1)*X(L) + 150 CONTINUE + GO TO 170 + 160 CONTINUE + MODE = 2 +C .........EXIT + GO TO 190 + 170 CONTINUE + 180 CONTINUE +C +C ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION. + CALL DSCAL(N,YNORM,X,1) + WNORM = DNRM2(N1,X,1) + 190 CONTINUE + 200 CONTINUE + RETURN + END +*DECK DWNNLS + SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, + + IWORK, WORK) +C***BEGIN PROLOGUE DWNNLS +C***PURPOSE Solve a linearly constrained least squares problem with +C equality constraints and nonnegativity constraints on +C selected variables. +C***LIBRARY SLATEC +C***CATEGORY K1A2A +C***TYPE REAL(KIND=R8) (WNNLS-S, DWNNLS-D) +C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, +C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, +C NONNEGATIVITY CONSTRAINTS, QUADRATIC PROGRAMMING +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C Abstract +C +C This subprogram solves a linearly constrained least squares +C problem. Suppose there are given matrices E and A of +C respective dimensions ME by N and MA by N, and vectors F +C and B of respective lengths ME and MA. This subroutine +C solves the problem +C +C EX = F, (equations to be exactly satisfied) +C +C AX = B, (equations to be approximately satisfied, +C in the least squares sense) +C +C subject to components L+1,...,N nonnegative +C +C Any values ME.GE.0, MA.GE.0 and 0.LE. L .LE.N are permitted. +C +C The problem is reposed as problem DWNNLS +C +C (WT*E)X = (WT*F) +C ( A) ( B), (least squares) +C subject to components L+1,...,N nonnegative. +C +C The subprogram chooses the heavy weight (or penalty parameter) WT. +C +C The parameters for DWNNLS are +C +C INPUT.. All TYPE REAL variables are REAL(KIND=R8) +C +C W(*,*),MDW, The array W(*,*) is double subscripted with first +C ME,MA,N,L dimensioning parameter equal to MDW. For this +C discussion let us call M = ME + MA. Then MDW +C must satisfy MDW.GE.M. The condition MDW.LT.M +C is an error. +C +C The array W(*,*) contains the matrices and vectors +C +C (E F) +C (A B) +C +C in rows and columns 1,...,M and 1,...,N+1 +C respectively. Columns 1,...,L correspond to +C unconstrained variables X(1),...,X(L). The +C remaining variables are constrained to be +C nonnegative. The condition L.LT.0 or L.GT.N is +C an error. +C +C PRGOPT(*) This double precision array is the option vector. +C If the user is satisfied with the nominal +C subprogram features set +C +C PRGOPT(1)=1 (or PRGOPT(1)=1.0) +C +C Otherwise PRGOPT(*) is a linked list consisting of +C groups of data of the following form +C +C LINK +C KEY +C DATA SET +C +C The parameters LINK and KEY are each one word. +C The DATA SET can be comprised of several words. +C The number of items depends on the value of KEY. +C The value of LINK points to the first +C entry of the next group of data within +C PRGOPT(*). The exception is when there are +C no more options to change. In that +C case LINK=1 and the values KEY and DATA SET +C are not referenced. The general layout of +C PRGOPT(*) is as follows. +C +C ...PRGOPT(1)=LINK1 (link to first entry of next group) +C . PRGOPT(2)=KEY1 (key to the option change) +C . PRGOPT(3)=DATA VALUE (data value for this change) +C . . +C . . +C . . +C ...PRGOPT(LINK1)=LINK2 (link to the first entry of +C . next group) +C . PRGOPT(LINK1+1)=KEY2 (key to the option change) +C . PRGOPT(LINK1+2)=DATA VALUE +C ... . +C . . +C . . +C ...PRGOPT(LINK)=1 (no more options to change) +C +C Values of LINK that are nonpositive are errors. +C A value of LINK.GT.NLINK=100000 is also an error. +C This helps prevent using invalid but positive +C values of LINK that will probably extend +C beyond the program limits of PRGOPT(*). +C Unrecognized values of KEY are ignored. The +C order of the options is arbitrary and any number +C of options can be changed with the following +C restriction. To prevent cycling in the +C processing of the option array a count of the +C number of options changed is maintained. +C Whenever this count exceeds NOPT=1000 an error +C message is printed and the subprogram returns. +C +C OPTIONS.. +C +C KEY=6 +C Scale the nonzero columns of the +C entire data matrix +C (E) +C (A) +C to have length one. The DATA SET for +C this option is a single value. It must +C be nonzero if unit length column scaling is +C desired. +C +C KEY=7 +C Scale columns of the entire data matrix +C (E) +C (A) +C with a user-provided diagonal matrix. +C The DATA SET for this option consists +C of the N diagonal scaling factors, one for +C each matrix column. +C +C KEY=8 +C Change the rank determination tolerance from +C the nominal value of SQRT(SRELPR). This quantity +C can be no smaller than SRELPR, The arithmetic- +C storage precision. The quantity used +C here is internally restricted to be at +C least SRELPR. The DATA SET for this option +C is the new tolerance. +C +C KEY=9 +C Change the blow-up parameter from the +C nominal value of SQRT(SRELPR). The reciprocal of +C this parameter is used in rejecting solution +C components as too large when a variable is +C first brought into the active set. Too large +C means that the proposed component times the +C reciprocal of the parameter is not less than +C the ratio of the norms of the right-side +C vector and the data matrix. +C This parameter can be no smaller than SRELPR, +C the arithmetic-storage precision. +C +C For example, suppose we want to provide +C a diagonal matrix to scale the problem +C matrix and change the tolerance used for +C determining linear dependence of dropped col +C vectors. For these options the dimensions of +C PRGOPT(*) must be at least N+6. The FORTRAN +C statements defining these options would +C be as follows. +C +C PRGOPT(1)=N+3 (link to entry N+3 in PRGOPT(*)) +C PRGOPT(2)=7 (user-provided scaling key) +C +C CALL DCOPY(N,D,1,PRGOPT(3),1) (copy the N +C scaling factors from a user array called D(*) +C into PRGOPT(3)-PRGOPT(N+2)) +C +C PRGOPT(N+3)=N+6 (link to entry N+6 of PRGOPT(*)) +C PRGOPT(N+4)=8 (linear dependence tolerance key) +C PRGOPT(N+5)=... (new value of the tolerance) +C +C PRGOPT(N+6)=1 (no more options to change) +C +C +C IWORK(1), The amounts of working storage actually allocated +C IWORK(2) for the working arrays WORK(*) and IWORK(*), +C respectively. These quantities are compared with +C the actual amounts of storage needed for DWNNLS( ). +C Insufficient storage allocated for either WORK(*) +C or IWORK(*) is considered an error. This feature +C was included in DWNNLS( ) because miscalculating +C the storage formulas for WORK(*) and IWORK(*) +C might very well lead to subtle and hard-to-find +C execution errors. +C +C The length of WORK(*) must be at least +C +C LW = ME+MA+5*N +C This test will not be made if IWORK(1).LE.0. +C +C The length of IWORK(*) must be at least +C +C LIW = ME+MA+N +C This test will not be made if IWORK(2).LE.0. +C +C OUTPUT.. All TYPE REAL variables are REAL(KIND=R8) +C +C X(*) An array dimensioned at least N, which will +C contain the N components of the solution vector +C on output. +C +C RNORM The residual norm of the solution. The value of +C RNORM contains the residual vector length of the +C equality constraints and least squares equations. +C +C MODE The value of MODE indicates the success or failure +C of the subprogram. +C +C MODE = 0 Subprogram completed successfully. +C +C = 1 Max. number of iterations (equal to +C 3*(N-L)) exceeded. Nearly all problems +C should complete in fewer than this +C number of iterations. An approximate +C solution and its corresponding residual +C vector length are in X(*) and RNORM. +C +C = 2 Usage error occurred. The offending +C condition is noted with the error +C processing subprogram, XERMSG( ). +C +C User-designated +C Working arrays.. +C +C WORK(*) A double precision working array of length at least +C M + 5*N. +C +C IWORK(*) An integer-valued working array of length at least +C M+N. +C +C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for +C linear least squares problems with equality and +C nonnegativity constraints, Report SAND77-0552, Sandia +C Laboratories, June 1978. +C K. H. Haskell and R. J. Hanson, Selected algorithms for +C the linearly constrained least squares problem - a +C users guide, Report SAND78-1290, Sandia Laboratories, +C August 1979. +C K. H. Haskell and R. J. Hanson, An algorithm for +C linear least squares problems with equality and +C nonnegativity constraints, Mathematical Programming +C 21 (1981), pp. 98-118. +C R. J. Hanson and K. H. Haskell, Two algorithms for the +C linearly constrained least squares problem, ACM +C Transactions on Mathematical Software, September 1982. +C C. L. Lawson and R. J. Hanson, Solving Least Squares +C Problems, Prentice-Hall, Inc., 1974. +C***ROUTINES CALLED DWNLSM, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and revised. (WRB & RWC) +C 891006 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900510 Convert XERRWV calls to XERMSG calls, change Prologue +C comments to agree with WNNLS. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C 180613 Removed prints and replaced DP --> REAL(KIND=R8). (THC) +C***END PROLOGUE DWNNLS + USE REAL_PRECISION + + INTEGER IWORK(*), L, L1, L2, L3, L4, L5, LIW, LW, MA, MDW, ME, + * MODE, N + REAL(KIND=R8) PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) +C CHARACTER*8 XERN1 +C***FIRST EXECUTABLE STATEMENT DWNNLS + MODE = 0 + IF (MA+ME.LE.0 .OR. N.LE.0) RETURN +C + IF (IWORK(1).GT.0) THEN + LW = ME + MA + 5*N + IF (IWORK(1).LT.LW) THEN +C WRITE (XERN1, '(I8)') LW +C CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // +C * 'ALLOCATED FOR WORK(*), NEED LW = ' // XERN1, 2, 1) + MODE = 2 + RETURN + ENDIF + ENDIF +C + IF (IWORK(2).GT.0) THEN + LIW = ME + MA + N + IF (IWORK(2).LT.LIW) THEN +C WRITE (XERN1, '(I8)') LIW +C CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // +C * 'ALLOCATED FOR IWORK(*), NEED LIW = ' // XERN1, 2, 1) + MODE = 2 + RETURN + ENDIF + ENDIF +C + IF (MDW.LT.ME+MA) THEN +C CALL XERMSG ('SLATEC', 'DWNNLS', +C * 'THE VALUE MDW.LT.ME+MA IS AN ERROR', 1, 1) + MODE = 2 + RETURN + ENDIF +C + IF (L.LT.0 .OR. L.GT.N) THEN +C CALL XERMSG ('SLATEC', 'DWNNLS', +C * 'L.GE.0 .AND. L.LE.N IS REQUIRED', 2, 1) + MODE = 2 + RETURN + ENDIF +C +C THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS +C WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS +C REQUIRED BY THE MAIN SUBROUTINE DWNLSM( ). +C + L1 = N + 1 + L2 = L1 + N + L3 = L2 + ME + MA + L4 = L3 + N + L5 = L4 + N +C + CALL DWNLSM(W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, IWORK, + * IWORK(L1), WORK(1), WORK(L1), WORK(L2), WORK(L3), + * WORK(L4), WORK(L5)) + RETURN + END +*DECK DWNLSM + SUBROUTINE DWNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, + + IPIVOT, ITYPE, WD, H, SCALE, Z, TEMP, D) +C***BEGIN PROLOGUE DWNLSM +C***SUBSIDIARY +C***PURPOSE Subsidiary to DWNNLS +C***LIBRARY SLATEC +C***TYPE REAL(KIND=R8) (WNLSM-S, DWNLSM-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C This is a companion subprogram to DWNNLS. +C The documentation for DWNNLS has complete usage instructions. +C +C In addition to the parameters discussed in the prologue to +C subroutine DWNNLS, the following work arrays are used in +C subroutine DWNLSM (they are passed through the calling +C sequence from DWNNLS for purposes of variable dimensioning). +C Their contents will in general be of no interest to the user. +C +C Variables of type REAL are REAL(KIND=R8). +C +C IPIVOT(*) +C An array of length N. Upon completion it contains the +C pivoting information for the cols of W(*,*). +C +C ITYPE(*) +C An array of length M which is used to keep track +C of the classification of the equations. ITYPE(I)=0 +C denotes equation I as an equality constraint. +C ITYPE(I)=1 denotes equation I as a least squares +C equation. +C +C WD(*) +C An array of length N. Upon completion it contains the +C dual solution vector. +C +C H(*) +C An array of length N. Upon completion it contains the +C pivot scalars of the Householder transformations performed +C in the case KRANK.LT.L. +C +C SCALE(*) +C An array of length M which is used by the subroutine +C to store the diagonal matrix of weights. +C These are used to apply the modified Givens +C transformations. +C +C Z(*),TEMP(*) +C Working arrays of length N. +C +C D(*) +C An array of length N that contains the +C column scaling for the matrix (E). +C (A) +C +C***SEE ALSO DWNNLS +C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, +C SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, +C DWNLIT, IDAMAX, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and revised. (WRB & RWC) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900328 Added TYPE section. (WRB) +C 900510 Fixed an error message. (RWC) +C 900604 DP version created from SP version. (RWC) +C 900911 Restriction on value of ALAMDA included. (WRB) +C***END PROLOGUE DWNLSM + USE REAL_PRECISION + + INTEGER IPIVOT(*), ITYPE(*), L, MA, MDW, MME, MODE, N + REAL(KIND=R8) D(*), H(*), PRGOPT(*), RNORM, SCALE(*), TEMP(*), + * W(MDW,*), WD(*), X(*), Z(*) +C + EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, SLATEC_DROTM, + * SLATEC_DROTMG, DSCAL, DSWAP, DWNLIT, IDAMAX, XERMSG + REAL(KIND=R8) D1MACH, DASUM, DNRM2 + INTEGER IDAMAX +C + REAL(KIND=R8) ALAMDA, ALPHA, ALSQ, AMAX, BLOWUP, BNORM, + * DOPE(3), DRELPR, EANORM, FAC, SM, SPARAM(5), T, TAU, WMAX, Z2, + * ZZ + INTEGER I, IDOPE(3), IMAX, ISOL, ITEMP, ITER, ITMAX, IWMAX, J, + * JCON, JP, KEY, KRANK, L1, LAST, LINK, M, ME, NEXT, NIV, NLINK, + * NOPT, NSOLN, NTIMES + LOGICAL DONE, FEASBL, FIRST, HITCON, POS +C + SAVE DRELPR, FIRST + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DWNLSM +C +C Initialize variables. +C DRELPR is the precision for the particular machine +C being used. This logic avoids resetting it every entry. +C + IF (FIRST) DRELPR = D1MACH(4) + FIRST = .FALSE. +C +C Set the nominal tolerance used in the code. +C + TAU = SQRT(DRELPR) +C + M = MA + MME + ME = MME + MODE = 2 +C +C To process option vector +C + FAC = 1.D-4 +C +C Set the nominal blow up factor used in the code. +C + BLOWUP = TAU +C +C The nominal column scaling used in the code is +C the identity scaling. +C + CALL DCOPY (N, 1.D0, 0, D, 1) +C +C Define bound for number of options to change. +C + NOPT = 1000 +C +C Define bound for positive value of LINK. +C + NLINK = 100000 + NTIMES = 0 + LAST = 1 + LINK = PRGOPT(1) + IF (LINK.LE.0 .OR. LINK.GT.NLINK) THEN +C CALL XERMSG ('SLATEC', 'DWNLSM', +C + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) + RETURN + ENDIF +C + 100 IF (LINK.GT.1) THEN + NTIMES = NTIMES + 1 + IF (NTIMES.GT.NOPT) THEN +C CALL XERMSG ('SLATEC', 'DWNLSM', +C + 'IN DWNNLS, THE LINKS IN THE OPTION VECTOR ARE CYCLING.', +C + 3, 1) + RETURN + ENDIF +C + KEY = PRGOPT(LAST+1) + IF (KEY.EQ.6 .AND. PRGOPT(LAST+2).NE.0.D0) THEN + DO 110 J = 1,N + T = DNRM2(M,W(1,J),1) + IF (T.NE.0.D0) T = 1.D0/T + D(J) = T + 110 CONTINUE + ENDIF +C + IF (KEY.EQ.7) CALL DCOPY (N, PRGOPT(LAST+2), 1, D, 1) + IF (KEY.EQ.8) TAU = MAX(DRELPR,PRGOPT(LAST+2)) + IF (KEY.EQ.9) BLOWUP = MAX(DRELPR,PRGOPT(LAST+2)) +C + NEXT = PRGOPT(LINK) + IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN +C CALL XERMSG ('SLATEC', 'DWNLSM', +C + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) + RETURN + ENDIF +C + LAST = LINK + LINK = NEXT + GO TO 100 + ENDIF +C + DO 120 J = 1,N + CALL DSCAL (M, D(J), W(1,J), 1) + 120 CONTINUE +C +C Process option vector +C + DONE = .FALSE. + ITER = 0 + ITMAX = 3*(N-L) + MODE = 0 + NSOLN = L + L1 = MIN(M,L) +C +C Compute scale factor to apply to equality constraint equations. +C + DO 130 J = 1,N + WD(J) = DASUM(M,W(1,J),1) + 130 CONTINUE +C + IMAX = IDAMAX(N,WD,1) + EANORM = WD(IMAX) + BNORM = DASUM(M,W(1,N+1),1) + ALAMDA = EANORM/(DRELPR*FAC) +C +C On machines, such as the VAXes using D floating, with a very +C limited exponent range for double precision values, the previously +C computed value of ALAMDA may cause an overflow condition. +C Therefore, this code further limits the value of ALAMDA. +C + ALAMDA = MIN(ALAMDA,SQRT(D1MACH(2))) +C +C Define scaling diagonal matrix for modified Givens usage and +C classify equation types. +C + ALSQ = ALAMDA**2 + DO 140 I = 1,M +C +C When equation I is heavily weighted ITYPE(I)=0, +C else ITYPE(I)=1. +C + IF (I.LE.ME) THEN + T = ALSQ + ITEMP = 0 + ELSE + T = 1.D0 + ITEMP = 1 + ENDIF + SCALE(I) = T + ITYPE(I) = ITEMP + 140 CONTINUE +C +C Set the solution vector X(*) to zero and the column interchange +C matrix to the identity. +C + CALL DCOPY (N, 0.D0, 0, X, 1) + DO 150 I = 1,N + IPIVOT(I) = I + 150 CONTINUE +C +C Perform initial triangularization in the submatrix +C corresponding to the unconstrained variables. +C Set first L components of dual vector to zero because +C these correspond to the unconstrained variables. +C + CALL DCOPY (L, 0.D0, 0, WD, 1) +C +C The arrays IDOPE(*) and DOPE(*) are used to pass +C information to DWNLIT(). This was done to avoid +C a long calling sequence or the use of COMMON. +C + IDOPE(1) = ME + IDOPE(2) = NSOLN + IDOPE(3) = L1 +C + DOPE(1) = ALSQ + DOPE(2) = EANORM + DOPE(3) = TAU + CALL DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM, + + IDOPE, DOPE, DONE) + ME = IDOPE(1) + KRANK = IDOPE(2) + NIV = IDOPE(3) +C +C Perform WNNLS algorithm using the following steps. +C +C Until(DONE) +C compute search direction and feasible point +C when (HITCON) add constraints +C else perform multiplier test and drop a constraint +C fin +C Compute-Final-Solution +C +C To compute search direction and feasible point, +C solve the triangular system of currently non-active +C variables and store the solution in Z(*). +C +C To solve system +C Copy right hand side into TEMP vector to use overwriting method. +C + 160 IF (DONE) GO TO 330 + ISOL = L + 1 + IF (NSOLN.GE.ISOL) THEN + CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) + DO 170 J = NSOLN,ISOL,-1 + IF (J.GT.KRANK) THEN + I = NIV - NSOLN + J + ELSE + I = J + ENDIF +C + IF (J.GT.KRANK .AND. J.LE.L) THEN + Z(J) = 0.D0 + ELSE + Z(J) = TEMP(I)/W(I,J) + CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) + ENDIF + 170 CONTINUE + ENDIF +C +C Increment iteration counter and check against maximum number +C of iterations. +C + ITER = ITER + 1 + IF (ITER.GT.ITMAX) THEN + MODE = 1 + DONE = .TRUE. + ENDIF +C +C Check to see if any constraints have become active. +C If so, calculate an interpolation factor so that all +C active constraints are removed from the basis. +C + ALPHA = 2.D0 + HITCON = .FALSE. + DO 180 J = L+1,NSOLN + ZZ = Z(J) + IF (ZZ.LE.0.D0) THEN + T = X(J)/(X(J)-ZZ) + IF (T.LT.ALPHA) THEN + ALPHA = T + JCON = J + ENDIF + HITCON = .TRUE. + ENDIF + 180 CONTINUE +C +C Compute search direction and feasible point +C + IF (HITCON) THEN +C +C To add constraints, use computed ALPHA to interpolate between +C last feasible solution X(*) and current unconstrained (and +C infeasible) solution Z(*). +C + DO 190 J = L+1,NSOLN + X(J) = X(J) + ALPHA*(Z(J)-X(J)) + 190 CONTINUE + FEASBL = .FALSE. +C +C Remove column JCON and shift columns JCON+1 through N to the +C left. Swap column JCON into the N th position. This achieves +C upper Hessenberg form for the nonactive constraints and +C leaves an upper Hessenberg matrix to retriangularize. +C + 200 DO 210 I = 1,M + T = W(I,JCON) + CALL DCOPY (N-JCON, W(I, JCON+1), MDW, W(I, JCON), MDW) + W(I,N) = T + 210 CONTINUE +C +C Update permuted index vector to reflect this shift and swap. +C + ITEMP = IPIVOT(JCON) + DO 220 I = JCON,N - 1 + IPIVOT(I) = IPIVOT(I+1) + 220 CONTINUE + IPIVOT(N) = ITEMP +C +C Similarly permute X(*) vector. +C + CALL DCOPY (N-JCON, X(JCON+1), 1, X(JCON), 1) + X(N) = 0.D0 + NSOLN = NSOLN - 1 + NIV = NIV - 1 +C +C Retriangularize upper Hessenberg matrix after adding +C constraints. +C + I = KRANK + JCON - L + DO 230 J = JCON,NSOLN + IF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.0) THEN +C +C Zero IP1 to I in column J +C + IF (W(I+1,J).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), + + W(I+1,J), SPARAM) + W(I+1,J) = 0.D0 + CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), + + MDW, SPARAM) + ENDIF + ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.1) THEN +C +C Zero IP1 to I in column J +C + IF (W(I+1,J).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), + + W(I+1,J), SPARAM) + W(I+1,J) = 0.D0 + CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), + + MDW, SPARAM) + ENDIF + ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.0) THEN + CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) + CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) + ITEMP = ITYPE(I+1) + ITYPE(I+1) = ITYPE(I) + ITYPE(I) = ITEMP +C +C Swapped row was formerly a pivot element, so it will +C be large enough to perform elimination. +C Zero IP1 to I in column J. +C + IF (W(I+1,J).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), + + W(I+1,J), SPARAM) + W(I+1,J) = 0.D0 + CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), + + MDW, SPARAM) + ENDIF + ELSEIF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.1) THEN + IF (SCALE(I)*W(I,J)**2/ALSQ.GT.(TAU*EANORM)**2) THEN +C +C Zero IP1 to I in column J +C + IF (W(I+1,J).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(I), SCALE(I+1), W(I,J), + + W(I+1,J), SPARAM) + W(I+1,J) = 0.D0 + CALL SLATEC_DROTM (N+1-J, W(I,J+1), MDW, + + W(I+1,J+1), MDW, SPARAM) + ENDIF + ELSE + CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) + CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) + ITEMP = ITYPE(I+1) + ITYPE(I+1) = ITYPE(I) + ITYPE(I) = ITEMP + W(I+1,J) = 0.D0 + ENDIF + ENDIF + I = I + 1 + 230 CONTINUE +C +C See if the remaining coefficients in the solution set are +C feasible. They should be because of the way ALPHA was +C determined. If any are infeasible, it is due to roundoff +C error. Any that are non-positive will be set to zero and +C removed from the solution set. +C + DO 240 JCON = L+1,NSOLN + IF (X(JCON).LE.0.D0) GO TO 250 + 240 CONTINUE + FEASBL = .TRUE. + 250 IF (.NOT.FEASBL) GO TO 200 + ELSE +C +C To perform multiplier test and drop a constraint. +C + CALL DCOPY (NSOLN, Z, 1, X, 1) + IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) +C +C Reclassify least squares equations as equalities as necessary. +C + I = NIV + 1 + 260 IF (I.LE.ME) THEN + IF (ITYPE(I).EQ.0) THEN + I = I + 1 + ELSE + CALL DSWAP (N+1, W(I,1), MDW, W(ME,1), MDW) + CALL DSWAP (1, SCALE(I), 1, SCALE(ME), 1) + ITEMP = ITYPE(I) + ITYPE(I) = ITYPE(ME) + ITYPE(ME) = ITEMP + ME = ME - 1 + ENDIF + GO TO 260 + ENDIF +C +C Form inner product vector WD(*) of dual coefficients. +C + DO 280 J = NSOLN+1,N + SM = 0.D0 + DO 270 I = NSOLN+1,M + SM = SM + SCALE(I)*W(I,J)*W(I,N+1) + 270 CONTINUE + WD(J) = SM + 280 CONTINUE +C +C Find J such that WD(J)=WMAX is maximum. This determines +C that the incoming column J will reduce the residual vector +C and be positive. +C + 290 WMAX = 0.D0 + IWMAX = NSOLN + 1 + DO 300 J = NSOLN+1,N + IF (WD(J).GT.WMAX) THEN + WMAX = WD(J) + IWMAX = J + ENDIF + 300 CONTINUE + IF (WMAX.LE.0.D0) GO TO 330 +C +C Set dual coefficients to zero for incoming column. +C + WD(IWMAX) = 0.D0 +C +C WMAX .GT. 0.D0, so okay to move column IWMAX to solution set. +C Perform transformation to retriangularize, and test for near +C linear dependence. +C +C Swap column IWMAX into NSOLN-th position to maintain upper +C Hessenberg form of adjacent columns, and add new column to +C triangular decomposition. +C + NSOLN = NSOLN + 1 + NIV = NIV + 1 + IF (NSOLN.NE.IWMAX) THEN + CALL DSWAP (M, W(1,NSOLN), 1, W(1,IWMAX), 1) + WD(IWMAX) = WD(NSOLN) + WD(NSOLN) = 0.D0 + ITEMP = IPIVOT(NSOLN) + IPIVOT(NSOLN) = IPIVOT(IWMAX) + IPIVOT(IWMAX) = ITEMP + ENDIF +C +C Reduce column NSOLN so that the matrix of nonactive constraints +C variables is triangular. +C + DO 320 J = M,NIV+1,-1 + JP = J - 1 +C +C When operating near the ME line, test to see if the pivot +C element is near zero. If so, use the largest element above +C it as the pivot. This is to maintain the sharp interface +C between weighted and non-weighted rows in all cases. +C + IF (J.EQ.ME+1) THEN + IMAX = ME + AMAX = SCALE(ME)*W(ME,NSOLN)**2 + DO 310 JP = J - 1,NIV,-1 + T = SCALE(JP)*W(JP,NSOLN)**2 + IF (T.GT.AMAX) THEN + IMAX = JP + AMAX = T + ENDIF + 310 CONTINUE + JP = IMAX + ENDIF +C + IF (W(J,NSOLN).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(JP), SCALE(J), W(JP,NSOLN), + + W(J,NSOLN), SPARAM) + W(J,NSOLN) = 0.D0 + CALL SLATEC_DROTM (N+1-NSOLN, W(JP,NSOLN+1), MDW, + + W(J,NSOLN+1), MDW, SPARAM) + ENDIF + 320 CONTINUE +C +C Solve for Z(NSOLN)=proposed new value for X(NSOLN). Test if +C this is nonpositive or too large. If this was true or if the +C pivot term was zero, reject the column as dependent. +C + IF (W(NIV,NSOLN).NE.0.D0) THEN + ISOL = NIV + Z2 = W(ISOL,N+1)/W(ISOL,NSOLN) + Z(NSOLN) = Z2 + POS = Z2 .GT. 0.D0 + IF (Z2*EANORM.GE.BNORM .AND. POS) THEN + POS = .NOT. (BLOWUP*Z2*EANORM.GE.BNORM) + ENDIF +C +C Try to add row ME+1 as an additional equality constraint. +C Check size of proposed new solution component. +C Reject it if it is too large. +C + ELSEIF (NIV.LE.ME .AND. W(ME+1,NSOLN).NE.0.D0) THEN + ISOL = ME + 1 + IF (POS) THEN +C +C Swap rows ME+1 and NIV, and scale factors for these rows. +C + CALL DSWAP (N+1, W(ME+1,1), MDW, W(NIV,1), MDW) + CALL DSWAP (1, SCALE(ME+1), 1, SCALE(NIV), 1) + ITEMP = ITYPE(ME+1) + ITYPE(ME+1) = ITYPE(NIV) + ITYPE(NIV) = ITEMP + ME = ME + 1 + ENDIF + ELSE + POS = .FALSE. + ENDIF +C + IF (.NOT.POS) THEN + NSOLN = NSOLN - 1 + NIV = NIV - 1 + ENDIF + IF (.NOT.(POS.OR.DONE)) GO TO 290 + ENDIF + GO TO 160 +C +C Else perform multiplier test and drop a constraint. To compute +C final solution. Solve system, store results in X(*). +C +C Copy right hand side into TEMP vector to use overwriting method. +C + 330 ISOL = 1 + IF (NSOLN.GE.ISOL) THEN + CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) + DO 340 J = NSOLN,ISOL,-1 + IF (J.GT.KRANK) THEN + I = NIV - NSOLN + J + ELSE + I = J + ENDIF +C + IF (J.GT.KRANK .AND. J.LE.L) THEN + Z(J) = 0.D0 + ELSE + Z(J) = TEMP(I)/W(I,J) + CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) + ENDIF + 340 CONTINUE + ENDIF +C +C Solve system. +C + CALL DCOPY (NSOLN, Z, 1, X, 1) +C +C Apply Householder transformations to X(*) if KRANK.LT.L +C + IF (KRANK.LT.L) THEN + DO 350 I = 1,KRANK + CALL DH12 (2, I, KRANK+1, L, W(I,1), MDW, H(I), X, 1, 1, 1) + 350 CONTINUE + ENDIF +C +C Fill in trailing zeroes for constrained variables not in solution. +C + IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) +C +C Permute solution vector to natural order. +C + DO 380 I = 1,N + J = I + 360 IF (IPIVOT(J).EQ.I) GO TO 370 + J = J + 1 + GO TO 360 +C + 370 IPIVOT(J) = IPIVOT(I) + IPIVOT(I) = J + CALL DSWAP (1, X(J), 1, X(I), 1) + 380 CONTINUE +C +C Rescale the solution using the column scaling. +C + DO 390 J = 1,N + X(J) = X(J)*D(J) + 390 CONTINUE +C + DO 400 I = NSOLN+1,M + T = W(I,N+1) + IF (I.LE.ME) T = T/ALAMDA + T = (SCALE(I)*T)*T + RNORM = RNORM + T + 400 CONTINUE +C + RNORM = SQRT(RNORM) + RETURN + END +*DECK DROTM + SUBROUTINE SLATEC_DROTM (N, DX, INCX, DY, INCY, DPARAM) +C***BEGIN PROLOGUE SLATEC_DROTM +C***PURPOSE Apply a modified Givens transformation. +C***LIBRARY SLATEC (BLAS) +C***CATEGORY D1A8 +C***TYPE REAL(KIND=R8) (SROTM-S, DROTM-D) +C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***DESCRIPTION +C +C B L A S Subprogram +C Description of Parameters +C +C --Input-- +C N number of elements in input vector(s) +C DX double precision vector with N elements +C INCX storage spacing between elements of DX +C DY double precision vector with N elements +C INCY storage spacing between elements of DY +C DPARAM 5-element D.P. vector. DPARAM(1) is DFLAG described below. +C Locations 2-5 of SPARAM contain elements of the +C transformation matrix H described below. +C +C --Output-- +C DX rotated vector (unchanged if N .LE. 0) +C DY rotated vector (unchanged if N .LE. 0) +C +C Apply the modified Givens transformation, H, to the 2 by N matrix +C (DX**T) +C (DY**T) , where **T indicates transpose. The elements of DX are +C in DX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else +C LX = 1+(1-N)*INCX, and similarly for DY using LY and INCY. +C +C With DPARAM(1)=DFLAG, H has one of the following forms: +C +C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 +C +C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) +C H=( ) ( ) ( ) ( ) +C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). +C +C See SLATEC_DROTMG for a description of data storage in DPARAM. +C +C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +C Krogh, Basic linear algebra subprograms for Fortran +C usage, Algorithm No. 539, Transactions on Mathematical +C Software 5, 3 (September 1979), pp. 308-323. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 791001 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920310 Corrected definition of LX in DESCRIPTION. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 180613 Renamed SLATEC_DROTM to avoid BLAS naming conflict. (THC) +C***END PROLOGUE SLATEC_DROTM + USE REAL_PRECISION + + REAL(KIND=R8) DFLAG, DH12, DH22, DX, TWO, Z, DH11, DH21, + 1 DPARAM, DY, W, ZERO + DIMENSION DX(*), DY(*), DPARAM(5) + SAVE ZERO, TWO + DATA ZERO, TWO /0.0D0, 2.0D0/ +C***FIRST EXECUTABLE STATEMENT SLATEC_DROTM + DFLAG=DPARAM(1) + IF (N.LE.0 .OR. (DFLAG+TWO.EQ.ZERO)) GO TO 140 + IF (.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 +C + NSTEPS=N*INCX +C IF (DFLAG) 50, 10, 30 +C Replaced obsolete code above with an IF-block (THC). + IF (DFLAG < 0) THEN + GO TO 50 + ELSE IF (DFLAG == 0) THEN + GO TO 10 + ELSE IF (DFLAG > 0) THEN + GO TO 30 + END IF + 10 CONTINUE + DH12=DPARAM(4) + DH21=DPARAM(3) + DO 20 I = 1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=W+Z*DH12 + DY(I)=W*DH21+Z + 20 CONTINUE + GO TO 140 + 30 CONTINUE + DH11=DPARAM(2) + DH22=DPARAM(5) + DO 40 I = 1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=W*DH11+Z + DY(I)=-W+DH22*Z + 40 CONTINUE + GO TO 140 + 50 CONTINUE + DH11=DPARAM(2) + DH12=DPARAM(4) + DH21=DPARAM(3) + DH22=DPARAM(5) + DO 60 I = 1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=W*DH11+Z*DH12 + DY(I)=W*DH21+Z*DH22 + 60 CONTINUE + GO TO 140 + 70 CONTINUE + KX=1 + KY=1 + IF (INCX .LT. 0) KX = 1+(1-N)*INCX + IF (INCY .LT. 0) KY = 1+(1-N)*INCY +C +C IF (DFLAG) 120,80,100 +C Replaced obsolete code above with an IF-block (THC). + IF (DFLAG < 0) THEN + GO TO 120 + ELSE IF (DFLAG == 0) THEN + GO TO 80 + ELSE IF (DFLAG > 0) THEN + GO TO 100 + END IF + 80 CONTINUE + DH12=DPARAM(4) + DH21=DPARAM(3) + DO 90 I = 1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=W+Z*DH12 + DY(KY)=W*DH21+Z + KX=KX+INCX + KY=KY+INCY + 90 CONTINUE + GO TO 140 + 100 CONTINUE + DH11=DPARAM(2) + DH22=DPARAM(5) + DO 110 I = 1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=W*DH11+Z + DY(KY)=-W+DH22*Z + KX=KX+INCX + KY=KY+INCY + 110 CONTINUE + GO TO 140 + 120 CONTINUE + DH11=DPARAM(2) + DH12=DPARAM(4) + DH21=DPARAM(3) + DH22=DPARAM(5) + DO 130 I = 1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=W*DH11+Z*DH12 + DY(KY)=W*DH21+Z*DH22 + KX=KX+INCX + KY=KY+INCY + 130 CONTINUE + 140 CONTINUE + RETURN + END +*DECK SLATEC_DROTMG + SUBROUTINE SLATEC_DROTMG (DD1, DD2, DX1, DY1, DPARAM) +C***BEGIN PROLOGUE SLATEC_DROTMG +C***PURPOSE Construct a modified Givens transformation. +C***LIBRARY SLATEC (BLAS) +C***CATEGORY D1B10 +C***TYPE REAL(KIND=R8) (SROTMG-S, DROTMG-D) +C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***DESCRIPTION +C +C B L A S Subprogram +C Description of Parameters +C +C --Input-- +C DD1 double precision scalar +C DD2 double precision scalar +C DX1 double precision scalar +C DX2 double precision scalar +C DPARAM D.P. 5-vector. DPARAM(1)=DFLAG defined below. +C Locations 2-5 contain the rotation matrix. +C +C --Output-- +C DD1 changed to represent the effect of the transformation +C DD2 changed to represent the effect of the transformation +C DX1 changed to represent the effect of the transformation +C DX2 unchanged +C +C Construct the modified Givens transformation matrix H which zeros +C the second component of the 2-vector (SQRT(DD1)*DX1,SQRT(DD2)* +C DY2)**T. +C With DPARAM(1)=DFLAG, H has one of the following forms: +C +C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 +C +C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) +C H=( ) ( ) ( ) ( ) +C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). +C +C Locations 2-5 of DPARAM contain DH11, DH21, DH12, and DH22, +C respectively. (Values of 1.D0, -1.D0, or 0.D0 implied by the +C value of DPARAM(1) are not stored in DPARAM.) +C +C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +C Krogh, Basic linear algebra subprograms for Fortran +C usage, Algorithm No. 539, Transactions on Mathematical +C Software 5, 3 (September 1979), pp. 308-323. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 780301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920316 Prologue corrected. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 180613 Renamed SLATEC_DROTMG to avoid BLAS naming conflict. (THC) +C***END PROLOGUE SLATEC_DROTMG + USE REAL_PRECISION + + REAL(KIND=R8) GAM, ONE, RGAMSQ, DD1, DD2, DH11, DH12, DH21, + 1 DH22, DPARAM, DP1, DP2, DQ1, DQ2, DU, DY1, ZERO, + 2 GAMSQ, DFLAG, DTEMP, DX1, TWO + DIMENSION DPARAM(5) + SAVE ZERO, ONE, TWO, GAM, GAMSQ, RGAMSQ + DATA ZERO, ONE, TWO /0.0D0, 1.0D0, 2.0D0/ + DATA GAM, GAMSQ, RGAMSQ /4096.0D0, 16777216.D0, 5.9604645D-8/ +C***FIRST EXECUTABLE STATEMENT SLATEC_DROTMG + IF (.NOT. DD1 .LT. ZERO) GO TO 10 +C GO ZERO-H-D-AND-DX1.. + GO TO 60 + 10 CONTINUE +C CASE-DD1-NONNEGATIVE + DP2=DD2*DY1 + IF (.NOT. DP2 .EQ. ZERO) GO TO 20 + DFLAG=-TWO + GO TO 260 +C REGULAR-CASE.. + 20 CONTINUE + DP1=DD1*DX1 + DQ2=DP2*DY1 + DQ1=DP1*DX1 +C + IF (.NOT. ABS(DQ1) .GT. ABS(DQ2)) GO TO 40 + DH21=-DY1/DX1 + DH12=DP2/DP1 +C + DU=ONE-DH12*DH21 +C + IF (.NOT. DU .LE. ZERO) GO TO 30 +C GO ZERO-H-D-AND-DX1.. + GO TO 60 + 30 CONTINUE + DFLAG=ZERO + DD1=DD1/DU + DD2=DD2/DU + DX1=DX1*DU +C GO SCALE-CHECK.. + GO TO 100 + 40 CONTINUE + IF (.NOT. DQ2 .LT. ZERO) GO TO 50 +C GO ZERO-H-D-AND-DX1.. + GO TO 60 + 50 CONTINUE + DFLAG=ONE + DH11=DP1/DP2 + DH22=DX1/DY1 + DU=ONE+DH11*DH22 + DTEMP=DD2/DU + DD2=DD1/DU + DD1=DTEMP + DX1=DY1*DU +C GO SCALE-CHECK + GO TO 100 +C PROCEDURE..ZERO-H-D-AND-DX1.. + 60 CONTINUE + DFLAG=-ONE + DH11=ZERO + DH12=ZERO + DH21=ZERO + DH22=ZERO +C + DD1=ZERO + DD2=ZERO + DX1=ZERO +C RETURN.. + GO TO 220 +C PROCEDURE..FIX-H.. + 70 CONTINUE + IF (.NOT. DFLAG .GE. ZERO) GO TO 90 +C + IF (.NOT. DFLAG .EQ. ZERO) GO TO 80 + DH11=ONE + DH22=ONE + DFLAG=-ONE + GO TO 90 + 80 CONTINUE + DH21=-ONE + DH12=ONE + DFLAG=-ONE + 90 CONTINUE +C GO TO IGO,(120,150,180,210) +C Replaced the above obsolete code with modern alternative (THC). + SELECT CASE(IGO) + CASE(120) + GO TO 120 + CASE(150) + GO TO 150 + CASE(180) + GO TO 180 + CASE(210) + GO TO 210 + END SELECT +C PROCEDURE..SCALE-CHECK + 100 CONTINUE + 110 CONTINUE + IF (.NOT. DD1 .LE. RGAMSQ) GO TO 130 + IF (DD1 .EQ. ZERO) GO TO 160 + IGO = 120 +C FIX-H.. + GO TO 70 + 120 CONTINUE + DD1=DD1*GAM**2 + DX1=DX1/GAM + DH11=DH11/GAM + DH12=DH12/GAM + GO TO 110 + 130 CONTINUE + 140 CONTINUE + IF (.NOT. DD1 .GE. GAMSQ) GO TO 160 + IGO = 150 +C FIX-H.. + GO TO 70 + 150 CONTINUE + DD1=DD1/GAM**2 + DX1=DX1*GAM + DH11=DH11*GAM + DH12=DH12*GAM + GO TO 140 + 160 CONTINUE + 170 CONTINUE + IF (.NOT. ABS(DD2) .LE. RGAMSQ) GO TO 190 + IF (DD2 .EQ. ZERO) GO TO 220 + IGO = 180 +C FIX-H.. + GO TO 70 + 180 CONTINUE + DD2=DD2*GAM**2 + DH21=DH21/GAM + DH22=DH22/GAM + GO TO 170 + 190 CONTINUE + 200 CONTINUE + IF (.NOT. ABS(DD2) .GE. GAMSQ) GO TO 220 + IGO = 210 +C FIX-H.. + GO TO 70 + 210 CONTINUE + DD2=DD2/GAM**2 + DH21=DH21*GAM + DH22=DH22*GAM + GO TO 200 + 220 CONTINUE +C IF (DFLAG) 250,230,240 +C Replaced obsolete code above with an IF-block (THC). + IF (DFLAG < 0) THEN + GO TO 250 + ELSE IF (DFLAG == 0) THEN + GO TO 230 + ELSE IF (DFLAG > 0) THEN + GO TO 240 + END IF + + 230 CONTINUE + DPARAM(3)=DH21 + DPARAM(4)=DH12 + GO TO 260 + 240 CONTINUE + DPARAM(2)=DH11 + DPARAM(5)=DH22 + GO TO 260 + 250 CONTINUE + DPARAM(2)=DH11 + DPARAM(3)=DH21 + DPARAM(4)=DH12 + DPARAM(5)=DH22 + 260 CONTINUE + DPARAM(1)=DFLAG + RETURN + END +*DECK DWNLIT + SUBROUTINE DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, + + RNORM, IDOPE, DOPE, DONE) +C***BEGIN PROLOGUE DWNLIT +C***SUBSIDIARY +C***PURPOSE Subsidiary to DWNNLS +C***LIBRARY SLATEC +C***TYPE REAL(KIND=R8) (WNLIT-S, DWNLIT-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C This is a companion subprogram to DWNNLS( ). +C The documentation for DWNNLS( ) has complete usage instructions. +C +C Note The M by (N+1) matrix W( , ) contains the rt. hand side +C B as the (N+1)st col. +C +C Triangularize L1 by L1 subsystem, where L1=MIN(M,L), with +C col interchanges. +C +C***SEE ALSO DWNNLS +C***ROUTINES CALLED DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, +C DSWAP, DWNLT1, DWNLT2, DWNLT3, IDAMAX +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890618 Completely restructured and revised. (WRB & RWC) +C 890620 Revised to make WNLT1, WNLT2, and WNLT3 subroutines. (RWC) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900604 DP version created from SP version. . (RWC) +C***END PROLOGUE DWNLIT + USE REAL_PRECISION + + INTEGER IDOPE(*), IPIVOT(*), ITYPE(*), L, M, MDW, N + REAL(KIND=R8) DOPE(*), H(*), RNORM, SCALE(*), W(MDW,*) + LOGICAL DONE +C + EXTERNAL DCOPY, DH12, SLATEC_DROTM, SLATEC_DROTMG, DSCAL, DSWAP, + * DWNLT1, DWNLT2, DWNLT3, IDAMAX + INTEGER IDAMAX + LOGICAL DWNLT2 +C + REAL(KIND=R8) ALSQ, AMAX, EANORM, FACTOR, HBAR, RN, SPARAM(5), + * T, TAU + INTEGER I, I1, IMAX, IR, J, J1, JJ, JP, KRANK, L1, LB, LEND, ME, + * MEND, NIV, NSOLN + LOGICAL INDEP, RECALC +C +C***FIRST EXECUTABLE STATEMENT DWNLIT + ME = IDOPE(1) + NSOLN = IDOPE(2) + L1 = IDOPE(3) +C + ALSQ = DOPE(1) + EANORM = DOPE(2) + TAU = DOPE(3) +C + LB = MIN(M-1,L) + RECALC = .TRUE. + RNORM = 0.D0 + KRANK = 0 +C +C We set FACTOR=1.0 so that the heavy weight ALAMDA will be +C included in the test for column independence. +C + FACTOR = 1.D0 + LEND = L + DO 180 I=1,LB +C +C Set IR to point to the I-th row. +C + IR = I + MEND = M + CALL DWNLT1 (I, LEND, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, + + W) +C +C Update column SS and find pivot column. +C + CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) +C +C Perform column interchange. +C Test independence of incoming column. +C + 130 IF (DWNLT2(ME, MEND, IR, FACTOR, TAU, SCALE, W(1,I))) THEN +C +C Eliminate I-th column below diagonal using modified Givens +C transformations applied to (A B). +C +C When operating near the ME line, use the largest element +C above it as the pivot. +C + DO 160 J=M,I+1,-1 + JP = J-1 + IF (J.EQ.ME+1) THEN + IMAX = ME + AMAX = SCALE(ME)*W(ME,I)**2 + DO 150 JP=J-1,I,-1 + T = SCALE(JP)*W(JP,I)**2 + IF (T.GT.AMAX) THEN + IMAX = JP + AMAX = T + ENDIF + 150 CONTINUE + JP = IMAX + ENDIF +C + IF (W(J,I).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(JP), SCALE(J), W(JP,I), + + W(J,I), SPARAM) + W(J,I) = 0.D0 + CALL SLATEC_DROTM (N+1-I, W(JP,I+1), MDW, W(J,I+1), + + MDW, SPARAM) + ENDIF + 160 CONTINUE + ELSE IF (LEND.GT.I) THEN +C +C Column I is dependent. Swap with column LEND. +C Perform column interchange, +C and find column in remaining set with largest SS. +C + CALL DWNLT3 (I, LEND, M, MDW, IPIVOT, H, W) + LEND = LEND - 1 + IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 + HBAR = H(IMAX) + GO TO 130 + ELSE + KRANK = I - 1 + GO TO 190 + ENDIF + 180 CONTINUE + KRANK = L1 +C + 190 IF (KRANK.LT.ME) THEN + FACTOR = ALSQ + DO 200 I=KRANK+1,ME + CALL DCOPY (L, 0.D0, 0, W(I,1), MDW) + 200 CONTINUE +C +C Determine the rank of the remaining equality constraint +C equations by eliminating within the block of constrained +C variables. Remove any redundant constraints. +C + RECALC = .TRUE. + LB = MIN(L+ME-KRANK, N) + DO 270 I=L+1,LB + IR = KRANK + I - L + LEND = N + MEND = ME + CALL DWNLT1 (I, LEND, ME, IR, MDW, RECALC, IMAX, HBAR, H, + + SCALE, W) +C +C Update col ss and find pivot col +C + CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) +C +C Perform column interchange +C Eliminate elements in the I-th col. +C + DO 240 J=ME,IR+1,-1 + IF (W(J,I).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), + + W(J,I), SPARAM) + W(J,I) = 0.D0 + CALL SLATEC_DROTM (N+1-I, W(J-1,I+1), MDW,W(J,I+1), + + MDW, SPARAM) + ENDIF + 240 CONTINUE +C +C I=column being eliminated. +C Test independence of incoming column. +C Remove any redundant or dependent equality constraints. +C + IF (.NOT.DWNLT2(ME, MEND, IR, FACTOR,TAU,SCALE,W(1,I))) THEN + JJ = IR + DO 260 IR=JJ,ME + CALL DCOPY (N, 0.D0, 0, W(IR,1), MDW) + RNORM = RNORM + (SCALE(IR)*W(IR,N+1)/ALSQ)*W(IR,N+1) + W(IR,N+1) = 0.D0 + SCALE(IR) = 1.D0 +C +C Reclassify the zeroed row as a least squares equation. +C + ITYPE(IR) = 1 + 260 CONTINUE +C +C Reduce ME to reflect any discovered dependent equality +C constraints. +C + ME = JJ - 1 + GO TO 280 + ENDIF + 270 CONTINUE + ENDIF +C +C Try to determine the variables KRANK+1 through L1 from the +C least squares equations. Continue the triangularization with +C pivot element W(ME+1,I). +C + 280 IF (KRANK.LT.L1) THEN + RECALC = .TRUE. +C +C Set FACTOR=ALSQ to remove effect of heavy weight from +C test for column independence. +C + FACTOR = ALSQ + DO 350 I=KRANK+1,L1 +C +C Set IR to point to the ME+1-st row. +C + IR = ME+1 + LEND = L + MEND = M + CALL DWNLT1 (I, L, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, + + W) +C +C Update column SS and find pivot column. +C + CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) +C +C Perform column interchange. +C Eliminate I-th column below the IR-th element. +C + DO 320 J=M,IR+1,-1 + IF (W(J,I).NE.0.D0) THEN + CALL SLATEC_DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), + + W(J,I), SPARAM) + W(J,I) = 0.D0 + CALL SLATEC_DROTM (N+1-I, W(J-1,I+1), MDW, W(J,I+1), + + MDW, SPARAM) + ENDIF + 320 CONTINUE +C +C Test if new pivot element is near zero. +C If so, the column is dependent. +C Then check row norm test to be classified as independent. +C + T = SCALE(IR)*W(IR,I)**2 + INDEP = T .GT. (TAU*EANORM)**2 + IF (INDEP) THEN + RN = 0.D0 + DO 340 I1=IR,M + DO 330 J1=I+1,N + RN = MAX(RN, SCALE(I1)*W(I1,J1)**2) + 330 CONTINUE + 340 CONTINUE + INDEP = T .GT. RN*TAU**2 + ENDIF +C +C If independent, swap the IR-th and KRANK+1-th rows to +C maintain the triangular form. Update the rank indicator +C KRANK and the equality constraint pointer ME. +C + IF (.NOT.INDEP) GO TO 360 + CALL DSWAP(N+1, W(KRANK+1,1), MDW, W(IR,1), MDW) + CALL DSWAP(1, SCALE(KRANK+1), 1, SCALE(IR), 1) +C +C Reclassify the least square equation as an equality +C constraint and rescale it. +C + ITYPE(IR) = 0 + T = SQRT(SCALE(KRANK+1)) + CALL DSCAL(N+1, T, W(KRANK+1,1), MDW) + SCALE(KRANK+1) = ALSQ + ME = ME+1 + KRANK = KRANK+1 + 350 CONTINUE + ENDIF +C +C If pseudorank is less than L, apply Householder transformation. +C from right. +C + 360 IF (KRANK.LT.L) THEN + DO 370 J=KRANK,1,-1 + CALL DH12 (1, J, KRANK+1, L, W(J,1), MDW, H(J), W, MDW, 1, + + J-1) + 370 CONTINUE + ENDIF +C + NIV = KRANK + NSOLN - L + IF (L.EQ.N) DONE = .TRUE. +C +C End of initial triangularization. +C + IDOPE(1) = ME + IDOPE(2) = KRANK + IDOPE(3) = NIV + RETURN + END +*DECK DWNLT1 + SUBROUTINE DWNLT1 (I, LEND, MEND, IR, MDW, RECALC, IMAX, HBAR, H, + + SCALE, W) +C***BEGIN PROLOGUE DWNLT1 +C***SUBSIDIARY +C***PURPOSE Subsidiary to WNLIT +C***LIBRARY SLATEC +C***TYPE REAL(KIND=R8) (WNLT1-S, DWNLT1-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C To update the column Sum Of Squares and find the pivot column. +C The column Sum of Squares Vector will be updated at each step. +C When numerically necessary, these values will be recomputed. +C +C***SEE ALSO DWNLIT +C***ROUTINES CALLED IDAMAX +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) +C 900604 DP version created from SP version. (RWC) +C***END PROLOGUE DWNLT1 + USE REAL_PRECISION + + INTEGER I, IMAX, IR, LEND, MDW, MEND + REAL(KIND=R8) H(*), HBAR, SCALE(*), W(MDW,*) + LOGICAL RECALC +C + EXTERNAL IDAMAX + INTEGER IDAMAX +C + INTEGER J, K +C +C***FIRST EXECUTABLE STATEMENT DWNLT1 + IF (IR.NE.1 .AND. (.NOT.RECALC)) THEN +C +C Update column SS=sum of squares. +C + DO 10 J=I,LEND + H(J) = H(J) - SCALE(IR-1)*W(IR-1,J)**2 + 10 CONTINUE +C +C Test for numerical accuracy. +C + IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 + RECALC = (HBAR+1.E-3*H(IMAX)) .EQ. HBAR + ENDIF +C +C If required, recalculate column SS, using rows IR through MEND. +C + IF (RECALC) THEN + DO 30 J=I,LEND + H(J) = 0.D0 + DO 20 K=IR,MEND + H(J) = H(J) + SCALE(K)*W(K,J)**2 + 20 CONTINUE + 30 CONTINUE +C +C Find column with largest SS. +C + IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 + HBAR = H(IMAX) + ENDIF + RETURN + END +*DECK DWNLT2 + LOGICAL FUNCTION DWNLT2 (ME, MEND, IR, FACTOR, TAU, SCALE, WIC) +C***BEGIN PROLOGUE DWNLT2 +C***SUBSIDIARY +C***PURPOSE Subsidiary to WNLIT +C***LIBRARY SLATEC +C***TYPE REAL(KIND=R8) (WNLT2-S, DWNLT2-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C To test independence of incoming column. +C +C Test the column IC to determine if it is linearly independent +C of the columns already in the basis. In the initial tri. step, +C we usually want the heavy weight ALAMDA to be included in the +C test for independence. In this case, the value of FACTOR will +C have been set to 1.E0 before this procedure is invoked. +C In the potentially rank deficient problem, the value of FACTOR +C will have been set to ALSQ=ALAMDA**2 to remove the effect of the +C heavy weight from the test for independence. +C +C Write new column as partitioned vector +C (A1) number of components in solution so far = NIV +C (A2) M-NIV components +C And compute SN = inverse weighted length of A1 +C RN = inverse weighted length of A2 +C Call the column independent when RN .GT. TAU*SN +C +C***SEE ALSO DWNLIT +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) +C 900604 DP version created from SP version. (RWC) +C***END PROLOGUE DWNLT2 + USE REAL_PRECISION + + REAL(KIND=R8) FACTOR, SCALE(*), TAU, WIC(*) + INTEGER IR, ME, MEND +C + REAL(KIND=R8) RN, SN, T + INTEGER J +C +C***FIRST EXECUTABLE STATEMENT DWNLT2 + SN = 0.E0 + RN = 0.E0 + DO 10 J=1,MEND + T = SCALE(J) + IF (J.LE.ME) T = T/FACTOR + T = T*WIC(J)**2 +C + IF (J.LT.IR) THEN + SN = SN + T + ELSE + RN = RN + T + ENDIF + 10 CONTINUE + DWNLT2 = RN .GT. SN*TAU**2 + RETURN + END +*DECK DWNLT3 + SUBROUTINE DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) +C***BEGIN PROLOGUE DWNLT3 +C***SUBSIDIARY +C***PURPOSE Subsidiary to WNLIT +C***LIBRARY SLATEC +C***TYPE REAL(KIND=R8) (WNLT3-S, DWNLT3-D) +C***AUTHOR Hanson, R. J., (SNLA) +C Haskell, K. H., (SNLA) +C***DESCRIPTION +C +C Perform column interchange. +C Exchange elements of permuted index vector and perform column +C interchanges. +C +C***SEE ALSO DWNLIT +C***ROUTINES CALLED DSWAP +C***REVISION HISTORY (YYMMDD) +C 790701 DATE WRITTEN +C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) +C 900604 DP version created from SP version. (RWC) +C***END PROLOGUE DWNLT3 + USE REAL_PRECISION + + INTEGER I, IMAX, IPIVOT(*), M, MDW + REAL(KIND=R8) H(*), W(MDW,*) +C + EXTERNAL DSWAP +C + REAL(KIND=R8) T + INTEGER ITEMP +C +C***FIRST EXECUTABLE STATEMENT DWNLT3 + IF (IMAX.NE.I) THEN + ITEMP = IPIVOT(I) + IPIVOT(I) = IPIVOT(IMAX) + IPIVOT(IMAX) = ITEMP +C + CALL DSWAP(M, W(1,IMAX), 1, W(1,I), 1) +C + T = H(IMAX) + H(IMAX) = H(I) + H(I) = T + ENDIF + RETURN + END diff --git a/src/test_install.f90 b/src/test_install.f90 new file mode 100644 index 0000000..8868896 --- /dev/null +++ b/src/test_install.f90 @@ -0,0 +1,153 @@ +PROGRAM TEST_INSTALL +! Driver code that tests the installation of DELAUNAYSPARSES and +! DELAUNAYSPARSEP. To do so, a toy interpolation problem is +! computed and the results are compared to the known solution. + +! Last Update: February, 2019 +! Primary Author: Tyler Chang +USE DELSPARSE_MOD +USE OMP_LIB +IMPLICIT NONE + +! Declare data. +INTEGER :: SIMPS(3,6), IERR(6) +REAL(KIND=R8) :: EPS +REAL(KIND=R8) :: INTERP_IN(1,20), INTERP_OUT(1,6), EXPECTED_OUT(1,6), & + & PTS(2,20), PTS_TMP(2,20), Q(2,6), Q_TMP(2,6), WEIGHTS(3,6) + +EPS = SQRT(EPSILON(0.0_R8)) +PTS = TRANSPOSE( RESHAPE( (/ & + 0.10877683233208346_R8, & + 0.65747571677546268_R8, & + 0.74853271200744009_R8, & + 0.25853058969031051_R8, & + 0.38508322804628770_R8, & + 0.19855613243388937_R8, & + 0.88590610193360986_R8, & + 0.73957680789581970_R8, & + 0.46130107231752082_R8, & + 0.61044888569019906_R8, & + 0.88848755836796889_R8, & + 0.56504950910258156_R8, & + 0.63374920061262452_R8, & + 0.47642100637444385_R8, & + 0.89167673297718886_R8, & + 0.85575976312324076_R8, & + 0.36741400280848768_R8, & + 0.22540743314109113_R8, & + 0.57887702455276135_R8, & + 0.33794226559725304_R8, & + 0.76211800269757757_R8, & + 0.082963515866522064_R8, & + 0.016220459783666152_R8, & + 0.17155847087049503_R8, & + 0.12930597950925682_R8, & + 0.91552991190955113_R8, & + 0.30469899967300274_R8, & + 0.064234640774060825_R8, & + 0.67129213095523377_R8, & + 0.56860397761470494_R8, & + 0.10547481357911370_R8, & + 0.59408216854500884_R8, & + 0.90989152079869851_R8, & + 0.91232248805035077_R8, & + 0.13873375923421827_R8, & + 0.68652421762380056_R8, & + 0.53775708104383380_R8, & + 0.63512621583969442_R8, & + 0.98798019619988187_R8, & + 0.87480704030477330_R8 /), & + (/ 20, 2 /) ) ) +Q = TRANSPOSE( RESHAPE( (/ & + 0.500000000000000000_R8, & + 0.250000000000000000_R8, & + 0.250000000000000000_R8, & + 0.750000000000000000_R8, & + 0.750000000000000000_R8, & + 0.100000000000000000_R8, & + 0.500000000000000000_R8, & + 0.250000000000000000_R8, & + 0.750000000000000000_R8, & + 0.250000000000000000_R8, & + 0.750000000000000000_R8, & + 0.500000000000000000_R8 /), & + (/6, 2/) ) ) +INTERP_IN = RESHAPE( (/ & + 0.87089483502966103_R8, & + 0.74043923264198475_R8, & + 0.76475317179110625_R8, & + 0.43008906056080554_R8, & + 0.51438920755554451_R8, & + 1.1140860443434404_R8, & + 1.1906051016066126_R8, & + 0.80381144866988052_R8, & + 1.1325932032727546_R8, & + 1.1790528633049040_R8, & + 0.99396237194708259_R8, & + 1.1591316776475904_R8, & + 1.5436407214113230_R8, & + 1.3887434944247947_R8, & + 1.0304104922114070_R8, & + 1.5422839807470412_R8, & + 0.90517108385232148_R8, & + 0.86053364898078555_R8, & + 1.5668572207526432_R8, & + 1.2127493059020265_R8 /), & + (/ 1, 20 /) ) +EXPECTED_OUT = RESHAPE( (/ & + 1.00000000000000000_R8, & + 0.50000000000000000_R8, & + 1.00000000000000000_R8, & + 1.00000000000000000_R8, & + 1.50000000000000000_R8, & + 0.68862615900613189_R8 /), & + (/ 1, 6/) ) + +! Test DELAUNAYSPARSES. +PTS_TMP = PTS; Q_TMP = Q +CALL DELAUNAYSPARSES(2, 20, PTS_TMP, 6, Q_TMP, SIMPS, WEIGHTS, IERR, & + & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT) +IF(ANY(ABS(INTERP_OUT - EXPECTED_OUT) > EPS)) THEN + WRITE(*,*) "DELAUNAYSPARSES produced an incorrect result. ", & + & " The installation is not correct." + STOP +END IF + +! Test DELAUNAYSPARSEP, PMODE=1. +PTS_TMP = PTS; Q_TMP = Q +CALL OMP_SET_NUM_THREADS(4) +CALL DELAUNAYSPARSEP(2, 20, PTS_TMP, 6, Q_TMP, SIMPS, WEIGHTS, IERR, & + & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT, PMODE=1) +IF(ANY(ABS(INTERP_OUT - EXPECTED_OUT) > EPS)) THEN + WRITE(*,*) "DELAUNAYSPARSEP produced an incorrect result. ", & + & " The installation is not correct." + STOP +END IF + +! Test DELAUNAYSPARSEP, PMODE=2. +PTS_TMP = PTS; Q_TMP = Q +CALL OMP_SET_NUM_THREADS(4) +CALL DELAUNAYSPARSEP(2, 20, PTS_TMP, 6, Q_TMP, SIMPS, WEIGHTS, IERR, & + & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT, PMODE=2) +IF(ANY(ABS(INTERP_OUT - EXPECTED_OUT) > EPS)) THEN + WRITE(*,*) "DELAUNAYSPARSEP produced an incorrect result. ", & + & " The installation is not correct." + STOP +END IF + +! Test DELAUNAYSPARSEP, PMODE=3. +CALL OMP_SET_NESTED(.TRUE.) +CALL OMP_SET_NUM_THREADS(2) +PTS_TMP = PTS; Q_TMP = Q +CALL DELAUNAYSPARSEP(2, 20, PTS_TMP, 6, Q_TMP, SIMPS, WEIGHTS, IERR, & + & INTERP_IN=INTERP_IN, INTERP_OUT=INTERP_OUT, PMODE=3) +IF(ANY(ABS(INTERP_OUT - EXPECTED_OUT) > EPS)) THEN + WRITE(*,*) "DELAUNAYSPARSEP produced an incorrect result. ", & + & " The installation is not correct." + STOP +END IF + +! If all the tests passed, then the installation is correct. +WRITE(*,*) "The installation of DELAUNAYSPARSE appears correct." + +END PROGRAM TEST_INSTALL